home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / FILES.PRG < prev    next >
Encoding:
Text File  |  1993-11-22  |  152.7 KB  |  4,214 lines
  1. *----------------------------------------------------------------------
  2. *-- Program...: FILES.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 08/02/1993
  5. *-- Notes.....: These are file processing routines. To see how to use
  6. *--             this library file, see: README.TXT.
  7. *----------------------------------------------------------------------
  8.  
  9. PROCEDURE AllTags
  10. *----------------------------------------------------------------------
  11. *-- Programmer..: Susan Perschke (SPECDATA)/Michael Liczbanski (LMIKE)
  12. *-- Date........: 01/03/1992
  13. *-- Notes.......: Used to bring up a list of MDX tags on screen for the
  14. *--               user, so they can change the current tag ... This was
  15. *--               gotten to me by Steve (LTI), from "Data Based
  16. *--               Advisor", December, 1991.
  17. *-- Written for.: dBASE IV, 1.1
  18. *-- Rev. History: 12/15/1991 - original procedure.
  19. *--               01/03/1992 - Ken Mayer -- added shadow ...
  20. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  21. *-- Called by...: Any
  22. *-- Usage.......: DO AllTags WITH nULRow, nULCol
  23. *-- Example.....: ON KEY LABEL F8 DO ALLTAGS WITH 02,60
  24. *-- Returns.....: None
  25. *-- Parameters..: nULRow -- Starting Row for Popup
  26. *--               nULCol -- Starting Column for Popup
  27. *----------------------------------------------------------------------
  28.  
  29.    parameters nULRow, nULCol
  30.    private nBar, cPrompt, nBRRow, nBRCol
  31.  
  32.    *-- Disable left/right arrow keys to prevent an accidental exit
  33.    on key label leftarrow  ?? chr(7)
  34.    on key label rightarrow ?? chr(7)
  35.  
  36.    *-- Save current screen
  37.    save screen to sTag
  38.    activate screen
  39.  
  40.    *-- define the popup
  41.    define popup pTag from m->nULRow, m->nULCol;
  42.       message " Press ENTER to select new index order...ESC to exit..."
  43.    nBar = 1                        && first bar
  44.    cPrompt    = "-No Index-"       &&  will always be this
  45.  
  46.    *-- loop to get the rest of 'em ...
  47.    do while "" <> m->cPrompt       && loop until no more tags
  48.        define bar nBar of pTag prompt (m->cPrompt)
  49.        cPrompt = tag(m->nBar)
  50.        nBar = m->nBar + 1
  51.    enddo
  52.  
  53.    on selection popup pTag deactivate popup
  54.  
  55.    *-- process shadow
  56.    nBRRow = m->nULRow + (m->nBar - 1) + 1
  57.              && bottom right for shadow (+1 for top, bottom)
  58.    nBRCol = m->nULCol + 11
  59.              && bottom right for shadow (+2 for sides, +9 for tagnames)
  60.    do shadow with m->nULRow, m->nULCol, m->nBRRow, m->nBRCol
  61.  
  62.    *-- do it
  63.    activate popup pTag
  64.  
  65.    *-- Assign a null string to cPrompt if "No Index" selected
  66.    cPrompt = iif(bar() = 1, "",prompt())
  67.  
  68.    *-- Don't change index order if ESC pressed
  69.    if bar() <> 0
  70.       set order to (m->cPrompt)
  71.    endif
  72.  
  73.    *-- cleanup
  74.    release popup pTag
  75.    restore screen from sTag
  76.    release screen sTag
  77.  
  78.    *-- Enable left/right arrow keys
  79.    on key label leftarrow
  80.    on key label rightarrow
  81.  
  82. RETURN
  83. *-- EoP: AllTags
  84.  
  85. PROCEDURE MakeTagFl
  86. *----------------------------------------------------------------------
  87. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  88. *-- Date........: 04/15/1992
  89. *-- Notes.......: Build a .dbf file from scratch, without using CREATE
  90. *--               FROM. The file built has three fields, TAGS1, TAGS2
  91. *--               and TAGS3, each character-type and 254 bytes wide.
  92. *-- Written for.: dBASE IV, 1.1
  93. *-- Rev. History: Broken out of other code and date-writing added
  94. *--               by Jay Parsons, 4/15/1992
  95. *--               Originally from the program PRGCREAT.ZIP
  96. *-- Called by...: Any
  97. *-- Usage.......: do MakeTagFl WITH "<cFname>"
  98. *-- Example.....: do MakeTagFl WITH "Tags"
  99. *-- Returns.....: None
  100. *-- Parameters..: cFname, name of the .dbf to create
  101. *-- Side effects: Creates a .DBF. Overwrites existing .DBF of same name
  102. *--               Disables external setting of PRINTER
  103. *----------------------------------------------------------------------
  104.  
  105.    parameters cFname
  106.    private cName
  107.    cName = m->cFname
  108.    if .not. "." $ m->cName
  109.       cName = m->cName + ".DBF"
  110.    endif
  111.    set printer to file ( m->cName )
  112.    set printer on
  113.    ??? "{3}"
  114.    ??? chr( year( date() - 1900 ) )
  115.    ??? chr( month( date() ) )
  116.    ??? chr( day( date() ) )
  117.    ??? "{0}{0}{0}{0}{129}{0}{251}{2}{0}{0}{0}{0}"
  118.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{201}{0}"  && Tags1
  119.    ??? "{84}{65}{71}{83}{49}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}"
  120.    ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Tags2
  121.    ??? "{84}{65}{71}{83}{50}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}"
  122.    ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Tags3
  123.    ??? "{84}{65}{71}{83}{51}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}"
  124.    ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  125.    ??? "{13}{26}"
  126.    set printer off
  127.    set printer to
  128.  
  129. RETURN
  130. *-- EoP: MakeTagFl
  131.  
  132. PROCEDURE RedoTags
  133. *----------------------------------------------------------------------
  134. *-- Programmer..: David Love (CIS: 70153,2433)
  135. *-- Date........: 04/18/1992
  136. *-- Notes.......: This routine is a "generic" MDX cleanup routine. It
  137. *--               is useful for handling "bloated" MDX files -- ones
  138. *--               that have been around awhile (they tend to be larger
  139. *--               than necessary). This routine will store the tag keys
  140. *--               in an array, delete the tags, and then rebuild the
  141. *--               MDX file from scratch, keeping all tag names and
  142. *--               keys, and the MDX SHOULD be smaller.
  143. *--               Will act on production mdx (ie. same name as dbf)
  144. *-- Written for.: dBASE IV, 1.5
  145. *-- Rev. History: 01/20/1992 - original function for dBASE IV Ver. 1.1.
  146. *--               04/18/1992 - David Love - adapted for use with beta
  147. *--                 version of dBASE IV, version 1.5.
  148. *--               (TAGCOUNT(), FOR(), DESCENDING(), UNIQUE() are 1.5
  149. *--                functions)
  150. *-- Calls.......: None
  151. *-- Called by...: Any
  152. *-- Usage.......: do RedoTags with "<cDBF>"
  153. *-- Example.....: do RedoTags with "Referral"
  154. *-- Returns.....: None
  155. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  156. *----------------------------------------------------------------------
  157.  
  158.    parameter cDBF
  159.  
  160.    use (cDBF) excl
  161.     
  162.    *-- First, figure out how many tags exist
  163.  
  164.    private nMaxTags
  165.    nMaxTags = tagcount( m->cDBF, 1 )
  166.     
  167.    *-- only perform routine if an index tag exists
  168.    if m->nMaxTags > 0
  169.       private nTags, mkey, mtag
  170.  
  171.       *-- store the keys and tags to an array
  172.       declare aTags[m->nMaxTags,5]
  173.       nTags = 1
  174.       do while nTags <= m->nMaxTags
  175.          && grab key
  176.          store key( (m->cDBF),m->nTags) to aTags[m->nTags,1]
  177.          && grab tagname
  178.          store tag( (m->cDBF),m->nTags) to aTags[m->nTags,2]
  179.          && grab for clause
  180.          store for( (m->cDBF),m->nTags) to aTags[m->nTags,3]
  181.          && .t. =descending
  182.          store descending( (m->cDBF),m->nTags) to aTags[m->nTags,4]
  183.          && .t. =unique
  184.          store unique( (m->cDBF),m->nTags) to aTags[m->nTags,5]
  185.          nTags = nTags + 1
  186.       enddo
  187.  
  188.       *-- now, delete the tags
  189.       do while "" # tag( (m->cDBF),1)
  190.          delete tag tag( (m->cDBF), 1)
  191.       enddo
  192.  
  193.       *-- rebuild the MDX, tag by tag ...
  194.       nTags = 1
  195.       do while nTags <= nMaxTags
  196.          mkey = aTags[m->nTags,1]+iif(""#aTags[m->nTags,3]," ;
  197.            for "+aTags[m->nTags,3],"") ;
  198.            + iif(aTags[m->nTags,4]," DESCENDING","") ;
  199.            + iif(aTags[m->nTags,5]," UNIQUE","")
  200.               mtag = aTags[m->nTags,2]
  201.          index on &mkey. tag &mtag.
  202.          nTags = m->nTags + 1
  203.       enddo
  204.  
  205.       *-- release the array ...
  206.       release aTags
  207.  
  208.    endif  && check for tags ...
  209.    use    && close database
  210.     
  211. RETURN
  212. *-- EoP: RedoTags
  213.  
  214. PROCEDURE AutoRedo
  215. *---------------------------------------------------------------------
  216. *-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
  217. *-- Date........: 03/06/1992
  218. *-- Notes.......: Displays a popup to choose a DBF from the current
  219. *--               directory to re-build its MDX file
  220. *-- Written for.: dBASE IV, 1.1
  221. *-- Rev. History: 03/04/1992 - original procedure.
  222. *--               03/06/1992 -- Ken Mayer added color parameter,
  223. *--                shadow to popup, and erase DBFS.DBF datafile at end.
  224. *-- Calls.......: LISTDBFS             Procedure in FILES.PRG
  225. *--               REDOTAGS             Procedure in FILES.PRG
  226. *--               CENTER               Procedure in PROC.PRG
  227. *--               YESNO2()             Function in PROC.PRG
  228. *--               SHADOW               Procedure in PROC.PRG       
  229. *--               EXTRCLR()            Function in PROC.PRG
  230. *-- Called by...: Any
  231. *-- Usage.......: do AutoRedo with nXTL,nYTL,nXBR,nYBR,cColor
  232. *-- Example.....: do AutoRedo with 5,34,15,47,"rg+/gb,w+/n,rg+/gb"
  233. *-- Returns.....: None
  234. *-- Parameters..: None
  235. *---------------------------------------------------------------------
  236.  
  237.    parameters nXTL, nYTL, nXBR, nYBR, cColor
  238.  
  239.    *-- Save Environment
  240.    cTalk = set("talk")
  241.    cStat = set("status")
  242.    cCloc = set("clock")
  243.    cScor = set("scoreboard")
  244.    cSafe = set("safety")
  245.  
  246.    *-- Set Environment
  247.    set stat off
  248.    set talk off
  249.    set cloc off
  250.    set scor off
  251.    set safe off
  252.  
  253.    *-- Full Screen Window for screen restoration when finished
  254.    define window wCoverScr from 0,0 to 23,79 none
  255.    activate window wCoverScr
  256.    clear
  257.  
  258.    *-- Make a Data File of the Current Directory
  259.    do center with 10,80,extrclr(m->cColor),;
  260.       '... Making Data File from Current Directory ...'
  261.    do ListDBFs
  262.  
  263.    use DBFS
  264.    index on DBFS->DBF tag IORDER
  265.  
  266.    *-- Define and access the popup of DataFiles
  267.    activate screen
  268.    define popup uDbfList from m->nXTL,m->nYTL to m->nXBR,m->nYBR ;
  269.       prompt field DBFS->DBF
  270.    on selection popup uDbfList deactivate popup
  271.  
  272.    *-- Execute loop for multiple re-indexes
  273.    clear
  274.    lLoop = .t.
  275.    do while m->lLoop
  276.       do shadow with m->nXTL,m->nYTL,m->nXBR,m->nYBR
  277.       activate popup uDbfList
  278.       clear  && get rid of shadow
  279.  
  280.       *--  Record prompt() and remove '.dbf' so it works with Redotag
  281.       cDataFile = substr(prompt(),1,len(trim(prompt()))-4)
  282.  
  283.       *-- Verify the MDX exists
  284.       if file(m->cDataFile+'.mdx')
  285.          do redotags with m->cDataFile
  286.       else
  287.          do center with 10,80,extrclr(m->cColor),;
  288.            '... Production MDX file not found for file '+m->cDataFile
  289.          n = inkey(0)
  290.          clear
  291.       endif
  292.  
  293.       *-- Determine if the user wants to re-build another
  294.       if YesNo2(.t.,"CC","",;
  295.          "Do you wish to reindex another file?","",m->cColor)
  296.          use DBFS order IORDER
  297.       else
  298.          lLoop = .f.
  299.       endif
  300.  
  301.    enddo
  302.  
  303.    *-- Restore environment
  304.    use DBFS
  305.    delete tag IORDER
  306.    use
  307.    erase DBFS.DBF
  308.    release popup uDbfList
  309.    deactivate window wCoverScr
  310.    release window wCoverScr
  311.    set stat &cStat.
  312.    set talk &cTalk.
  313.    set cloc &cCloc.
  314.    set scor &cScor.
  315.    set safe &cSafe.
  316.  
  317. RETURN
  318. *-- EoP:  AutoRedo
  319.  
  320. PROCEDURE PrntTags
  321. *----------------------------------------------------------------------
  322. *-- Programmer..: David Love (CIS: 70153,2433)
  323. *-- Date........: 03/24/1993
  324. *-- Notes.......: This routine is a "quick and not-so-dirty" method of
  325. *--               printing the tag and key expressions for a dbf's
  326. *--               production mdx file. It obviates the need for DISP or
  327. *--               LIST STAT TO PRINT (or DISP STAT with SHIFT+PrtScr).
  328. *--               This code is modified from the procedure RedoTags,
  329. *--               previously posted on the BORBBS.
  330. *--             : The proc will print the full key expression,
  331. *--               including FOR/DESCENDING/UNIQUE options, if present.
  332. *-- Written for.: dBASE IV, 1.1
  333. *-- Rev. History: 01/31/1992 - original procedure for dBASE IV, Ver 1.1
  334. *--               04/18/1992 - David Love - revised for version 1.5
  335. *--               03/24/1993 - Lee Hite - modified so that wild card
  336. *--                            specs may now be used to list multiple
  337. *--                            .DBF's. also, added optional parameter
  338. *--                            to include file structure in output.
  339. *-- Calls.......: ADIR()               Function in FILES.PRG
  340. *--               PARSPATH()           Function in FILES.PRG
  341. *--               SHELLSORT()          Function in ARRAY.PRG
  342. *--               NOTE: These are called only when using wildcards.
  343. *-- Called by...: Any
  344. *-- Usage.......: do PrntTags with "<cDBF>",[lDispStru]
  345. *-- Example.....: do PrntTags with "Referral"
  346. *--               do PrntTags with "*.dbf",.t.
  347. *-- Returns.....: None
  348. *-- Parameters..: cDBF      = Name of DATABASE file, may include
  349. *--                           wildcard specs(i.e., "REF*").  No
  350. *--                           extension is necessary, but if it's
  351. *--                           there, it better be ".DBF" <g>
  352. *--               lDispStru = [optional] set to .T. to include the file
  353. *--                           structure in the output
  354. *----------------------------------------------------------------------
  355.  
  356.    parameter cDBFParm,lDispStru
  357.  
  358.    private cTalk
  359.    cTalk = set("TALK")
  360.    set talk off
  361.    set printer on
  362.  
  363.    *-- handle whether or not we got a wild card
  364.    private cDBFPath,cDBFMask,nDBFs,aMyArray,lDummy,nKntr
  365.    if "*" $ m->cDBFParm .or. "?" $ m->cDBFParm
  366.       *-- wildcards, so build an array of the file names
  367.       cDBFMask = iif(at(".DBF",upper(m->cDBFParm))>0,;
  368.                      m->cDBFParm, m->cDBFParm+".DBF")
  369.       nDBFs = aDir(m->cDBFMask,"","")
  370.       if nDBFs > 0
  371.          declare aMyArray[m->nDBFs,1]
  372.          nKntr = 1
  373.          do while m->nKntr <= m->nDBFs
  374.             aMyArray[m->nKntr,1] = gaDir[m->nKntr,1]
  375.             nKntr = m->nKntr + 1
  376.          enddo
  377.          lDummy = ShellSort(m->nDBFs)
  378.       endif
  379.       cDBFPath = ParsPath(m->cDBFMask)
  380.    else
  381.       *-- no wild cards, so we just have one entry in the array
  382.       private aMyArray
  383.       declare aMyArray[1,1]
  384.       aMyArray[1,1] = upper(m->cDBFParm)
  385.       nDBFs = 1
  386.       cDBFPath = ""
  387.    endif
  388.  
  389.    *-- loop for each .DBF
  390.    private cDBF,nKntr
  391.    nKntr = 1
  392.    do while m->nKntr <= m->nDBFs
  393.       cDBF = aMyArray[m->nKntr,1]
  394.       *-- pull extension out of file name so TAGCOUNT(), etc. work...
  395.       cDBF = iif(at(".DBF",m->cDBF)=0,m->cDBF,;
  396.              left(m->cDBF,at(".DBF",m->cDBF)-1))
  397.       use (cDBFPath+cDBF)
  398.       ?? "DATABASE: "+m->cDBF at 0
  399.       ?
  400.       ?
  401.  
  402.       *-- display file structure if optioned
  403.       if lDispStru
  404.          ?? "STRUCTURE:" at 0
  405.          disp stru
  406.          ?
  407.       endif
  408.     
  409.       *-- now, figure out how many tags exist
  410.       private nMaxTags
  411.       nMaxTags = tagcount( m->cDBF )
  412.       ?? "INDEX TAGS:" at 0
  413.       ?
  414.     
  415.       *-- only perform routine if an index tag exists
  416.       if m->nMaxTags > 0
  417.          private nTags, mkey, mtag
  418.  
  419.          *-- store the keys and tags to an array
  420.          declare aTags[m->nMaxTags,5]
  421.          nTags = 1
  422.          do while m->nTags <= m->nMaxTags
  423.             * grab the key
  424.             store key( (m->cDBF),m->nTags) to aTags[m->nTags,1]
  425.             * grab the tagname
  426.             store tag( (m->cDBF),m->nTags) to aTags[m->nTags,2]
  427.             * grab the for clause
  428.             store for( (m->cDBF),m->nTags) to aTags[m->nTags,3]
  429.             * .t. if descending
  430.             store descending( (m->cDBF),m->nTags) to aTags[m->nTags,4]
  431.             * .t. if unique
  432.             store unique( (m->cDBF),m->nTags) to aTags[m->nTags,5]
  433.             nTags = m->nTags + 1
  434.          enddo
  435.  
  436.          *-- print each tag with it's key expression
  437.          ?? "Tag" at 0
  438.          ?? "Key Expression" AT 12
  439.          ?
  440.          nTags = 1
  441.          do while m->nTags <= m->nMaxTags
  442.             ?? aTags[m->nTags,2] AT 0
  443.             ?? aTags[m->nTags,1] + ;
  444.                iif(""#aTags[m->nTags,3]," FOR "+aTags[m->nTags,3],"") +;
  445.                iif(aTags[m->nTags,4]," DESCENDING","") + ;
  446.                iif(aTags[m->nTags,5]," UNIQUE","") AT 12
  447.             ?
  448.             nTags = m->nTags + 1
  449.          enddo
  450.  
  451.          *-- release the array ...
  452.          release aTags
  453.  
  454.       else
  455.          *-- no tags found
  456.          ?? "none" at 0
  457.          ?
  458.       endif  && check for tags ...
  459.       use    && close database
  460.       ?? replicate("=",60) at 0
  461.       ?
  462.       nKntr = m->nKntr + 1
  463.  
  464.    enddo  && loop for each .dbf
  465.  
  466.    *-- restore the environment
  467.    release gaDir
  468.    set printer off
  469.    set talk &cTalk.
  470.    
  471. RETURN
  472. *-- EoP: PrntTags
  473.  
  474. PROCEDURE ListDBFs
  475. *----------------------------------------------------------------------
  476. *-- Programmer..: David Love (70153,2433)
  477. *-- Date........: 01/31/1992
  478. *-- Notes.......: This procedure will create a list of the database
  479. *--               (.dbf) files in the current directory.  It will
  480. *--               create a database file named Dbfs.dbf which exists
  481. *--               of one 12-character field--Dbf. It will also create
  482. *--               a text file, Dbfs.txt, through the LIST FILES to FILE
  483. *--               command.  Then it will append records to the Dbfs.dbf
  484. *--               file and erase the Dbfs.txt file.
  485. *--               This Dbfs.dbf file can be SCANned, or used in a POPUP
  486. *--               PROMPT FIELD command, or in any other way imaginable.
  487. *--               The file 'Dbfs.dbf' will not be included in the
  488. *--               Dbfs.dbf file.
  489. *-- WARNING===>   If your application includes a file with the name of
  490. *--               'Dbfs.dbf', it will be overwritten with the file
  491. *--                created by this procedure.
  492. *-- Written for.: dBASE IV, 1.1
  493. *-- Rev. History: 01/31/1992 -- Original
  494. *-- Calls.......: None
  495. *-- Called by...: Any
  496. *-- Usage.......: do ListDBFs
  497. *-- Example.....: do ListDBFs
  498. *-- Returns.....: None
  499. *-- Parameters..: None
  500. *----------------------------------------------------------------------
  501.  
  502.    private cConsole
  503.    *-- Write the directory of dbf files to a text file (Dbfs.txt)
  504.    *-- First, erase the file if it exists
  505.    if file("Dbfs.txt")
  506.      erase dbfs.txt
  507.    endif
  508.  
  509.    *-- And, erase the dbfs.dbf file if it exists (so won't be included
  510.    *-- in the list)
  511.    if file("Dbfs.dbf")
  512.       erase Dbfs.dbf
  513.    endif
  514.  
  515.    *-- Now, write the dbfs.txt file
  516.    cConsole = set("CONSOLE")
  517.    set console off
  518.    list files to file dbfs.txt
  519.    set console &cConsole.
  520.  
  521.    *-- Then, create the file DBFS.DBF
  522.    *-- Acknowledgement..: Bowen Moursund for code that creates Dbfs.dbf
  523.    set printer to file DBFS.DBF
  524.    set printer on
  525.    ??? "{3}{92}{2}{1}{0}{0}{0}{0}{65}{0}{13}{0}{0}{0}{0}{0}{0}{0}"+;
  526.    "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{89}{0}{68}{66}{70}{0}{0}"+;
  527.    "{0}{0}{0}{0}{0}{0}{67}{3}{0}{44}{85}{12}{0}{0}{0}{1}{0}{0}{0}"+;
  528.    "{0}{0}{0}{0}{0}{0}{0}{0}{13}{26}"
  529.    set printer to
  530.    set printer off
  531.  
  532.    *-- Now, append dbfs.txt to dbfs.dbf if the record is a dbf listing.
  533.    use Dbfs
  534.    append from Dbfs.txt for ".DBF" $ Dbf type sdf
  535.  
  536.    use    && can remove this command if you want
  537.  
  538.    erase Dbfs.txt            && don't need it anymore
  539.  
  540. RETURN
  541. *--EOP: ListDBFs
  542.  
  543. FUNCTION Recompile
  544. *----------------------------------------------------------------------
  545. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  546. *--               Adapted from Compall.prg/Compall2.prg by James Thomas
  547. *-- Date........: 06/10/1992
  548. *-- Notes.......: Recompiles all dBASE source-code files.  Takes three
  549. *--               optional parameters:
  550. *--               Directory to recompile. Default is current directory.
  551. *--               Skeleton to recompile.  Default is all of .PRG, .LBG,
  552. *--               .FRG, .PRS, .FMT, .QBE and .UPD files.  If a skeleton
  553. *--               is provided that matches files that are not dBASE
  554. *--               source-code files, compiler errors will occur and,
  555. *--               in the absence of external error handling, see below,
  556. *--               suspend processing.
  557. *--               "Runtime" or any characters starting with "R" or "r"
  558. *--               to direct that compilation use the "RUNTIME" option.
  559. *--               Does not recompile a file if a file of the same root
  560. *--               name, an .??O extension and a later timestamp resides
  561. *--               in the directory.
  562. *--               Renames compilations of FMT, FRG, LBG and QBO files
  563. *--               to ??O.
  564. *--               Returns .T. if successful, or .F.
  565. *--              
  566. *--               Listing of compilation errors requires SET ALTERNATE
  567. *--               TO, and trapping such errors as passing the name of a
  568. *--               file that does not contain dBASE source code to the
  569. *--               COMPILE command requires an ON ERROR trap.  These are
  570. *--               omitted here due to lack of ways to prevent the
  571. *--               function from changing these settings externally.
  572. *--               Lines needed to have any compilation errors print to
  573. *--               the alternate file are included as comments.
  574. *-- Written for.: dBASE IV Version 1.5.
  575. *--               Adaptation for 1.1 may require changing the way
  576. *--               parameters are handled, and also rewriting the lines
  577. *--               that use fdate() and ftime() to read timestamps.
  578. *-- Rev. History: 04/07/1992 - original function.
  579. *--               04/13/1992 - additional environment settings.
  580. *--               04/16/1992 - aliases added thanks to BOWEN.
  581. *--               06/10/1992 - a few minor bug fixes
  582. *--               08/02/1993 - references to cDir corrected
  583. *-- Calls.......: Makestru()            FUNCTION in FILES.PRG
  584. *-- Called by...: Any
  585. *-- Usage.......: Recompile ( [<cDir>] [,<cSkel> [,"R"]] )
  586. *-- Example.....: ? Recompile ( "\dBASE\Myprogs", "*.??G" )
  587. *-- Parameters..: cDir, a DOS directory name ( and path if needed )
  588. *--               cSkel, skeleton using wildcards for files to compile
  589. *--               cRun, "R" or "r" if compilation is for Runtime
  590. *-- Side effects: Creates compiled .??O files, overwriting any of the
  591. *--               same root names that may exist.
  592. *----------------------------------------------------------------------
  593.  
  594.    parameters cDirectry, cSkeleton, cRun
  595.    private cCons, cAlias, cAlt, cDir, cSafety, cTempfile,;
  596.            cSrcfile, cObjfile, cString1, cString2, cRunopt
  597.  
  598.    * preserve environment
  599.    cCons = set( "CONSOLE" )
  600.    SET CONSOLE OFF
  601.    cAlias = alias()
  602.    cAlt = set( "ALTERNATE" )
  603.    SET ALTERNATE OFF
  604.    cDir = set( "DIRECTORY" )
  605.    IF type( "cDir" ) = "C" .AND. "" # cDir
  606.       SET DIRECTORY TO &cDir.
  607.    ENDIF
  608.    cSafety = set( "SAFETY" )
  609.    SET SAFETY OFF
  610.    SELECT select()
  611.  
  612.    * make temporary structure file & fill in the DOS DIR listing struc
  613.    cTempfile = Makestru()
  614.    USE ( cTempfile ) ALIAS cTempfile
  615.    APPEND BLANK
  616.    REPLACE FIELD_NAME WITH "FILENAME", FIELD_TYPE WITH "C", ;
  617.       FIELD_LEN WITH 9, FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  618.    APPEND BLANK
  619.    REPLACE FIELD_NAME WITH "EXT", FIELD_TYPE WITH "C", ;
  620.       FIELD_LEN WITH 4, FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  621.    APPEND BLANK
  622.    REPLACE FIELD_NAME WITH "FLENGTH", FIELD_TYPE WITH "C", ;
  623.       FIELD_LEN WITH 10, FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  624.    APPEND BLANK
  625.    REPLACE FIELD_NAME WITH "TIMESTAMP", FIELD_TYPE WITH "C", ;
  626.       FIELD_LEN WITH 16, FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  627.  
  628.    * make .dbf for source file names, reset and return if error occurs
  629.    cSrcfile = m->cTempfile
  630.    DO WHILE file ( m->cSrcfile + ".DBF" )
  631.       cSrcfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  632.    ENDDO
  633.    CREATE ( cSrcfile ) FROM  ( cTempfile )
  634.    USE ( cSrcfile ) alias cSrcfile
  635.  
  636.    IF "" = alias()
  637.       ERASE ( m->cTempfile +".DBF" )
  638.       SET DIRECTORY TO &cDir.
  639.       SET ALTERNATE &cAlt.
  640.       IF "" # m->cAlias
  641.          SELECT ( cAlias )
  642.       ENDIF
  643.       SET CONSOLE &cCons.
  644.       RETURN .F.
  645.    ENDIF
  646.  
  647.    * and for object file names
  648.    SELECT select()
  649.    USE ( cTempfile ) ALIAS cTempfile
  650.    GO 1
  651.    REPLACE FIELD_IDX WITH "Y"
  652.    cObjfile = m->cSrcfile
  653.    DO WHILE file ( m->cObjfile + ".DBF"  )
  654.       cObjfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  655.    ENDDO
  656.    CREATE ( cObjfile ) FROM (cTempfile)
  657.    use ( cObjfile ) alias cObjfile order filename
  658.    IF "" = alias()
  659.       ERASE ( m->cTempfile + ".DBF" )
  660.       SELECT cSrcfile
  661.       USE
  662.       ERASE ( m->cSrcfile + ".DBF" )
  663.       SET DIRECTORY TO &cDir.
  664.       SET ALTERNATE &cAlt.
  665.       IF "" # cAlias
  666.          SELECT  ( m->cAlias )
  667.       ENDIF
  668.       SET CONSOLE &cCons.
  669.       RETURN .F.
  670.    ENDIF
  671.  
  672.    * reuse name of cTempfile as SDF
  673.    cString1 = m->cTempfile + ".DBF"
  674.  
  675.    * DIR names of source files to it and append
  676.    RUN dir *.* > &cString1.
  677.    SELECT  cSrcfile
  678.    APPEND FROM ( cString1 ) TYPE SDF
  679.  
  680.    * delete unwanted directory entries
  681.    IF type("cSkeleton") = "C" .AND. "" # m->cSkeleton
  682.       DELETE ALL FOR .NOT. like( upper( m->cSkeleton ), ;
  683.                                  trim( Filename ) + "." + trim( Ext ) )
  684.    ELSE
  685.       DELETE ALL FOR .NOT. Ext $ "PRG LBG FRG PRS FMT QBE UPD "
  686.    ENDIF
  687.    PACK
  688.  
  689.    * reuse again for .??O files
  690.    RUN dir *.??o > &cString1.
  691.    SELECT cObjfile
  692.    APPEND FROM ( cString1 ) TYPE SDF
  693.    DELETE ALL FOR left( Filename, 1 ) = " " .OR. right( Ext, 2 ) # "O "
  694.    PACK
  695.    ERASE ( cString1 )
  696.  
  697.    * assemble Runtime option
  698.    cRunopt = iif( type( "cRun" ) = "C" .AND. "" # m->cRun ;
  699.              .AND. left( m->cRun, 1 ) $ "Rr", " RUNTIME", "" )
  700.  
  701.    * now compile all the files that need it
  702.    SELECT cSrcfile
  703.    SCAN
  704.       cString1 = trim( Filename ) + "." + trim( Ext )
  705.       *   Is there an object file of this name?
  706.       IF Seek( Filename, "cObjfile" )
  707.          cString2 = trim(cObjfile->Filename) + "." + trim(cObjfile->Ext)
  708.          cString2 = dtos( fdate( m->cString2 ) ) + ftime( m->cString2 )
  709.          *   then check timestamps and skip it if already compiled
  710.          IF dtos(fdate(m->cString1)) + ftime(m->cString1) < m->cString2
  711.             LOOP
  712.          ENDIF
  713.       ENDIF
  714.       *   compile it otherwise, listing errors if enabled
  715.       cString2 = m->cString1 + m->cRunopt
  716.       * SET ALTERNATE ON
  717.       * ? "Compiling " + m->cString2
  718.       COMPILE &cString2.
  719.       * ?
  720.       * SET ALTERNATE OFF
  721.       *   and rename object files that should not be .DBOs
  722.       IF Ext $ "FMT FRG LBG QBE "
  723.          cString2 = stuff( m->cString1, len( m->cString1 ), 1, "O" )
  724.          IF file( m->cString2 )
  725.             ERASE ( m->cString2 )
  726.          ENDIF
  727.          cString1 = trim( Filename ) + ".DBO"
  728.          RENAME ( m->cString1 ) TO ( m->cString2 )
  729.       ENDIF
  730.    ENDSCAN
  731.  
  732.    *  Clean up
  733.    USE
  734.    ERASE ( m->cSrcfile + ".DBF" )
  735.    SELECT cObjfile
  736.    USE
  737.    ERASE ( m->cObjfile + ".DBF" )
  738.    ERASE ( m->cObjfile + ".MDX" )
  739.    SET SAFETY &cSafety.
  740.    SET DIRECTORY TO &cDir.
  741.    SET ALTERNATE &cAlt.
  742.    IF "" # m->cAlias
  743.       SELECT ( m->cAlias )
  744.    ENDIF
  745.    SET CONSOLE &cCons.
  746.  
  747. RETURN .T.
  748. *-- Eof() Recompile
  749.  
  750. PROCEDURE Makedbf
  751. *----------------------------------------------------------------------
  752. *-- Programmer..: Jay Parsons (CIS: 72662,1302).
  753. *-- Date........: 04/26/1992
  754. *-- Notes.......: Makes an empty dBASE .dbf file
  755. *-- Written for.: dBASE IV, 1.1, 1.5
  756. *-- Rev. History: 04/26/1992 -- Original
  757. *-- Calls.......: Tempname()          function in FILES.PRG
  758. *-- Called by...: Any
  759. *-- Usage.......: DO MakeDbf WITH <cFilename>, <cStrufile>, <cArray>
  760. *-- Example.....: DO MakeDbf WITH Customers, cCustfields
  761. *-- Parameters..: cFilename - filename ( without extension ) of the
  762. *--                           .dbf to be created.
  763. *--               cStrufile - name ( without extension ) of a STRUCTURE
  764. *--                           EXTENDED .dbf
  765. *--               cArray    - name of the array holding field
  766. *--                           information for the .dbf.  The array must
  767. *--                           be dimensioned [ F, 5 ] where F is the
  768. *--                           number of fields.  Each row must hold
  769. *--                           data for one field:
  770. *--                 [ F, 1 ]  field name, character
  771. *--                 [ F, 2 ]  field type, character from set "CDFLMN"
  772. *--                 [ F, 3 ]  field length, numeric.  If field type is
  773. *--                             D, L, or M, will be ignored
  774. *--                 [ F, 4 ]  field decimals, numeric. optional if 0.
  775. *--                 [ F, 5 ]  field is mdx tag, char $ "YN", optional
  776. *--                             if N
  777. *----------------------------------------------------------------------
  778.  
  779.    parameters cFname, cSname, aAname
  780.    private nX,cF1,cF2,cF3,cF4,cF5,cStrufile,cFtype
  781.  
  782.    cF1 = m->aAname + "[nX,1]"
  783.    cF2 = m->aAname + "[nX,2]"
  784.    cF3 = m->aAname + "[nX,3]"
  785.    cF4 = m->aAname + "[nX,4]"
  786.    cF5 = m->aAname + "[nX,5]"
  787.    select select()
  788.    use ( m->cSname ) ALIAS cSname
  789.    zap
  790.    nX = 1
  791.    do while type( m->cF1 ) # "U"
  792.       cFtype = &cF2.
  793.       append blank
  794.       replace Field_name with m->&cF1., Field_type with m->cFtype
  795.       do case
  796.          case m->cFtype = "D"
  797.             replace Field_len with 8
  798.          case m->cFtype = "M"
  799.             replace Field_len with 10
  800.          case m->cFtype = "L"
  801.             replace Field_len with 1
  802.          otherwise
  803.             replace Field_len with m->&cF3.
  804.       endcase
  805.       if type( m->cF4 ) = "N" .and. m->cFtype $ "FN"
  806.          replace Field_dec with m->&cF4.
  807.       else
  808.          replace Field_dec with 0
  809.       endif
  810.       if type(m->cF5) # "U" .and. m->cFtype $ "CDFN" .and. m->&cF5.= "Y"
  811.          replace Field_idx with "Y"
  812.       else
  813.          replace Field_idx with "N"
  814.       endif
  815.       nX = m->nX + 1
  816.    enddo
  817.    use
  818.    create ( m->cFname ) FROM ( m->cSname )
  819.  
  820. RETURN
  821. *-- EoP: Makedbf
  822.  
  823. PROCEDURE MakeDBF2
  824. *----------------------------------------------------------------------
  825. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  826. *-- Date........: 02/22/1993
  827. *-- Notes.......: Creates an empty DBF file of the structure specified
  828. *--               in the array aMakeDBF[], which must be declared and
  829. *--               initialized with the proper values before calling
  830. *--               this procedure. The array must be declared as
  831. *--               aMakeDBF[n,5], where n is the number of fields in the
  832. *--               DBF to be created. The columns of the array
  833. *--               correspond to the fields of a structure extended file
  834. *--               and must be initialized to the appropriate values,
  835. *--               before calling this procedure, 1 row for each field.
  836. *--               Structure of a structure extended file:
  837. *--               Field    Type  Len  Dec
  838. *--               -----------------------
  839. *--               FIELD_NAME  C   10    0
  840. *--               FIELD_TYPE  C    1    0
  841. *--               FIELD_LEN   N    3    0
  842. *--               FIELD_DEC   N    3    0
  843. *--               FIELD_IDX   C    1    0
  844. *--
  845. *--               aMakeDBF[n,1] = Field name: 10 or less characters
  846. *--               aMakeDBF[n,2] = Field type: 1 character
  847. *--                               "C" = character
  848. *--                               "N" = numeric
  849. *--                               "F" = float
  850. *--                               "D" = date
  851. *--                               "L" = logical
  852. *--                               "M" = memo
  853. *--               aMakeDBF[n,3] = Field length: numeric
  854. *--                               "C" = 1 - 254
  855. *--                               "N","F" = use dBASE guidelines
  856. *--                               "D" = 8
  857. *--                               "L" = 1
  858. *--                               "M" = 10
  859. *--               aMakeDBF[n,4] = Decimal places: numeric
  860. *--                               0 for non numeric fields
  861. *--               aMakeDBF[n,5] = MDX flag: 1 char, "Y" or "N"
  862. *--
  863. *-- Written for.: dBASE IV, 1.5
  864. *-- Rev. History: 05/27/1992 -- Original Release
  865. *--               02/22/1993 -- Minor changes to PRIVATE calls.
  866. *-- Calls.......: None
  867. *-- Called by...: Any
  868. *-- Usage.......: do MakeDBF with <cDBFpath>,<cStruPath>
  869. *-- Example.....: cStruPath = MakeStru2(.f.)
  870. *--               declare aMakeDBF[1,5]
  871. *--               aMakeDBF[1,1] = "FIELD1"
  872. *--               aMakeDBF[1,2] = "C"
  873. *--               aMakeDBF[1,3] = 20
  874. *--               aMakeDBF[1,4] = 0
  875. *--               aMakeDBF[1,5] = "N"
  876. *--               do MakeDBF2 with "foo", cStruPath
  877. *--               erase (cStruPath+".dbf")
  878. *--               release aMakeDBF
  879. *-- Returns.....: none
  880. *-- Parameters..: cDBFpath = the [path]filename of DBF to be created.
  881. *--               cStruPath = the [path]filename of an empty structure
  882. *--                           extended file.
  883. *----------------------------------------------------------------------
  884.  
  885.    parameters cDBFpath,cStruPath
  886.    if pcount() = 2  && we need 2 parms
  887.       private cAlias
  888.       if type("aMakeDBF[1,1]") = "C"  && check array validity
  889.          cAlias = alias()
  890.          select select()
  891.          use (m->cStruPath)
  892.          append from array aMakeDBF
  893.          use
  894.          create (m->cDBFpath) from (m->cStruPath)
  895.          use
  896.          if "" # m->cAlias
  897.             select (m->cAlias)
  898.          endif
  899.       endif
  900.    endif
  901.  
  902. RETURN
  903. *-- EoP: MakeDBF2
  904.  
  905. FUNCTION Makestru
  906. *----------------------------------------------------------------------
  907. *-- Programmer..: Martin Leon (Hman), formerly sysop of A-T BBS
  908. *--               Revised by Jay Parsons, (CIS: 72662,1302).
  909. *-- Date........: 04/24/1992
  910. *-- Notes.......: Makes an empty dBASE STRUCTURE EXTENDED file and
  911. *--               returns its root name
  912. *-- Written for.: dBASE IV v1.5
  913. *-- Rev. History: 06/12/91 - original function.
  914. *--               04/07/92 - Now takes no parameter, returns filename
  915. *--               04/10/92 - Preserves catalog status and name
  916. *--               04/24/92 - Use of Tempname() added
  917. *--               05/28/92 - set("safety") check/minor mods, B.Moursund
  918. *-- Calls.......: Tempname()          Function in FILES.PRG
  919. *-- Called by...: Any
  920. *-- Usage.......: Makestru()
  921. *-- Example.....: Tempfile = Makestru()
  922. *-- Returns.....: Name of file created
  923. *-- Parameters..: None
  924. *----------------------------------------------------------------------
  925.  
  926.    private all
  927.    lTitleOn = ( set("TITLE") = "ON" )
  928.    lSafeOn = ( set("SAFETY") = "ON" )
  929.    lCatOff = ( set("CATALOG") = "OFF" )
  930.    cAlias = alias()
  931.    cTmpCat = TempName("cat") + ".CAT"
  932.    set title off
  933.    set safety off
  934.    cCatalog = catalog()
  935.    set catalog to (cTmpCat)
  936.    set catalog to &cCatalog.
  937.    cStruName = TempName("dbf")
  938.    select select()
  939.    use (m->cTmpCat) nosave
  940.    copy to (m->cStruName) structure extended
  941.    use (m->cStruName) exclusive
  942.    zap
  943.    use
  944.    if lTitleOn
  945.       set title on
  946.    endif
  947.    if lSafeOn
  948.       set safety on
  949.    endif
  950.    if lCatOff
  951.       set catalog off
  952.    endif
  953.    if "" # m->cAlias
  954.       select (m->cAlias)
  955.    endif
  956.     
  957. RETURN cStruname
  958. *-- Eof: Makestru()
  959.  
  960. FUNCTION MakeStru2
  961. *----------------------------------------------------------------------
  962. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  963. *-- Date........: 05/27/1992
  964. *-- Notes.......: Create an empty STRUCTURE EXTENDED file, using DBASE
  965. *--               print redirection. If specified, the file will be
  966. *--               created in the subdirectory pointed to by the DOS
  967. *--               environment variable DBTMP, if it is set, otherwise
  968. *--               in the current subdirectory.
  969. *--
  970. *--               Structure of a STRUCTURE EXTENDED file:
  971. *--               Field    Type  Len  Dec
  972. *--               -----------------------
  973. *--               FIELD_NAME  C   10    0
  974. *--               FIELD_TYPE  C    1    0
  975. *--               FIELD_LEN   N    3    0
  976. *--               FIELD_DEC   N    3    0
  977. *--               FIELD_IDX   C    1    0
  978. *--
  979. *-- Written for.: dBASE IV v1.1
  980. *-- Rev. History: 05/27/1992 -- Original
  981. *-- Calls.......: TEMPNAME()           Function in FILES.PRG
  982. *-- Called by...: Any, except when printing
  983. *-- Usage.......: MakeStru(<lDBTMP>)
  984. *-- Example.....: cStruPath = MakeStru2(.T.)
  985. *-- Returns.....: The name, no extension, of the file created.
  986. *-- Parameters..: lDBTMP = create file in DBTMP subdirectory, or not.
  987. *-- Side Effects: WARNING: Do not call when printing.
  988. *----------------------------------------------------------------------
  989.  
  990.    parameter lDBTMP
  991.    private all
  992.    cDBTMP = ""  && TempName() will assign this, if lDBTMP
  993.    if lDBTMP
  994.       cFname = TempName( "dbf", .t. )
  995.    else
  996.       cFname = TempName( "dbf", .f. )
  997.    endif
  998.    cPath = iif( "" # m->cDBTMP, m->cDBTMP, ;
  999.                set("DIRECTORY") ) + "\" + m->cFname + ".DBF"
  1000.    dDate = date()
  1001.    set printer to file (m->cPath)
  1002.    set printer on
  1003.    * Thanks to JPARSONS for suggestion to document the header structure
  1004.    ??? "{3}"           && various bit flags
  1005.    ??? chr(year(dDate)-1900) + chr(month(dDate)) + ;
  1006.        chr(day(dDate)) && date bytes in YYMMDD format
  1007.    ??? "{0}{0}{0}{0}"  && no. of records
  1008.    ??? "{193}{0}"      && no. of bytes in header
  1009.    ??? "{19}{0}"       && no. of bytes per record
  1010.    ??? "{0}{0}"        && reserved
  1011.    ??? "{0}"           && incomplete transaction flag
  1012.    ??? "{0}"           && encryption flag
  1013.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}" + ;
  1014.        "{0}{0}{0}"     && multi-user reserved
  1015.    ??? "{0}"           && MDX flag
  1016.    ??? "{0}{0}{0}"     && reserved
  1017.    * field descriptors
  1018.        * Field_Name
  1019.    ??? "{70}{73}{69}{76}{68}{95}{78}{65}{77}{69}{0}{67}{3}{0}{208}" + ;
  1020.        "{72}{10}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1021.        * Field_Type
  1022.    ??? "{70}{73}{69}{76}{68}{95}{84}{89}{80}{69}{0}{67}{13}{0}{208}" +;
  1023.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1024.        * Field_Len
  1025.    ??? "{70}{73}{69}{76}{68}{95}{76}{69}{78}{0}{0}{78}{14}{0}{208}" + ;
  1026.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1027.        * Field_Dec
  1028.    ??? "{70}{73}{69}{76}{68}{95}{68}{69}{67}{0}{0}{78}{17}{0}{208}" + ;
  1029.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1030.        * Field_Idx
  1031.    ??? "{70}{73}{69}{76}{68}{95}{73}{68}{88}{0}{0}{67}{20}{0}{208}" + ;
  1032.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1033.    ??? "{13}{26}"
  1034.    set printer to
  1035.    set printer off
  1036.  
  1037. RETURN cFname
  1038. *-- Eof() MakeStru2
  1039.  
  1040. FUNCTION TempName
  1041. *----------------------------------------------------------------------
  1042. *-- Programmer..: Martin Leon (HMAN)  Former Sysop, ATBBS
  1043. *-- Date........: 02/22/1993
  1044. *-- Notes.......: Obtain a name for temporary file of a given extension
  1045. *--               that does not conflict with existing files.
  1046. *-- Written for.: dBASE IV, v1.5
  1047. *-- Rev. History: Originally part of Makestru(), 6-12-1991
  1048. *--               04/26/92, made a separate function - Jay Parsons
  1049. *--               05/27/92, added lDBTMP option - Bowen Moursund
  1050. *--               02/22/93, Minor update to PRIVATE command.
  1051. *-- Calls.......: None
  1052. *-- Called by...: Any
  1053. *-- Usage.......: TempName( cExt , lDBTMP )
  1054. *-- Example.....: Sortfile = TempName( "DBF" , .t. )
  1055. *-- Returns.....: Name not already in use. Additionally, if the memvar
  1056. *--               cDBTMP is declared before calling the function with
  1057. *--               the lDBTMP option, it will be assigned the result
  1058. *--               of getenv("DBTMP").
  1059. *-- Parameters..: cExt   = Extension of temporary ( without the "." )
  1060. *--               lDBTMP = Optional. If .t., function returns unique
  1061. *--                        file name in the DBTMP subdirectory.
  1062. *-- Side Effects: The function will return a unique filename for the
  1063. *--               DEFAULT subdirectory if the lDBTMP option is used and
  1064. *--               the DOS environment variable DBTMP does not point to
  1065. *--               a valid subdirectory.
  1066. *----------------------------------------------------------------------
  1067.  
  1068.    parameters cExt, lDBTMP
  1069.    private cDefDir
  1070.    cDefDir = set("DIRECTORY")
  1071.    if lDBTMP
  1072.       cDBTMP = getenv("DBTMP")
  1073.       if "" # m->cDBTMP
  1074.          set directory to &cDBTMP.
  1075.       endif
  1076.    endif
  1077.    do while .t.
  1078.       Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  1079.       if .not. file(m->Fname + "." + m->cExt) .and. ;
  1080.         ( upper(m->cExt) # "DBF" .or. .not. ( file(m->Fname + ".MDX") ;
  1081.         .or. file (m->Fname + ".DBT") ) )
  1082.          exit
  1083.       endif
  1084.    enddo
  1085.    set directory to &cDefDir.
  1086.  
  1087. RETURN Fname
  1088. *-- Eof() TempName
  1089.  
  1090. PROCEDURE FileMove
  1091. *----------------------------------------------------------------------
  1092. *-- Programmer..: David Frankenbach (FRNKNBCH)
  1093. *--               DF Software Development, Inc.
  1094. *--               PO Box 87
  1095. *--               Forest, VA, 24551
  1096. *--               (804) 237-2342
  1097. *-- Date........: 02/11/1992
  1098. *-- Notes.......: This procedure gives the record movement allowed with
  1099. *--               EDIT when you use a simple @SAY/GET..READ. It allows
  1100. *--               you to pre/post process each record during editing,
  1101. *--               something you can't do with EDIT. This works best
  1102. *--               with a single file, although it would work with a
  1103. *--               parent->child relation. You should:  SELECT child and
  1104. *--               SET SKIP to child. This will allow the user to change
  1105. *--               the parent record pointer though! If you want to
  1106. *--               limit the child record movement to a single parent
  1107. *--               record, you can use a conditional index, or add logic
  1108. *--               to the routine to limit the record pointer movement.
  1109. *--               For these cases I have a seperate FileMove procedure,
  1110. *--               but they are not generic enough for publication.
  1111. *--
  1112. *--               These keys are trapped:
  1113. *--               UpArw, Shift-Tab, LeftArw, Ctrl-LeftArw, PgUp = 
  1114. *--                                                 backward one record
  1115. *--               DnArw, Tab, RightArw, Ctrl-RightArw, PgDn, Enter,
  1116. *--                                       Ctrl-End = forward one record
  1117. *--               Ctrl-PgUp = top of database or active index
  1118. *--               Ctrl-PgDn = bottom of database or active index
  1119. *-- Written for.: dBASE IV, 1.1
  1120. *-- Rev. History: 06/17/1991 - original routine.
  1121. *--               02/07/1992 -- Ken Mayer, brought into one PROCEDURE,
  1122. *--               rather than a function and a procedure ...
  1123. *--               02/11/1992 -- Author, additional documentation
  1124. *--                             Released into Public Domain
  1125. *-- Calls.......: None
  1126. *-- Called by...: None
  1127. *-- Usage.......: do FileMove with <nKey>
  1128. *--               where: <nKey> is the return value of readkey()
  1129. *-- Parameters..: nKey = last keystroke from a READKEY() call ...
  1130. *-- Returns.....: None
  1131. *-- Side Effects: Moves record pointer in current file if lMove = .t.
  1132. *-- Example.....:
  1133. *--  lMove = .t.  && if you want the user to be able to
  1134. *--               && move the  record pointer in my
  1135. *--               && applications if the user is adding a
  1136. *--               && new record I usually lMove = .f., for
  1137. *--               && editing I allow them to move through
  1138. *--               && the records.
  1139. *--  lOk = .t.
  1140. *--  do while ( lOk )
  1141. *--     do Mem_Load               && load memvars from record
  1142. *--     @say/gets                 && display/get the memvars
  1143. *--     read
  1144. *--     i = readkey()             && grab last key ...
  1145. *--     lOk = ( i <> 27 )         && if Esc was pressed lOK is false
  1146. *--     if ( lOk )
  1147. *--        if ( i > 256 )         && if record is changed
  1148. *--           do Mem_Unload       && replace dbf fields from memvars
  1149. *--        endif  && ( i > 256 )
  1150. *--        if ( lMove )           && if ok to move record pointer
  1151. *--           do FileMove with i  && <----- Move it
  1152. *--        else
  1153. *--           lOk = .f.            && terminate loop if .not. lMove
  1154. *--        endif  && ( lMove )
  1155. *--     endif && (lOK)
  1156. *--  enddo && while (lOK)
  1157. *----------------------------------------------------------------------
  1158.    parameter nKey
  1159.    private n
  1160.  
  1161.    m->n = m->nKey
  1162.    if ( m->n > 255 )     && if value is > 256, record has changed, but
  1163.       m->n = m->n - 256  && we want values < 256 to figure out which
  1164.    endif                 && direction to move from the readkey() table
  1165.  
  1166.    do case
  1167.  
  1168.       *-- keys to move backward through database 1 record at a time ...
  1169.       *--  LeftArw, Ctrl-LeftArw, UpArw, Shift-Tab, PgUp
  1170.       case ( m->n = 0 ) .or. ( m->n = 2 ) .or. ;
  1171.            ( m->n = 4 ) .or. ( m->n = 6 )
  1172.          if ( .not. bof() )           && if not at beginning of file
  1173.             skip -1                   && move backward one record
  1174.          endif
  1175.  
  1176.       *-- keys to move forward through database 1 record at a time ...
  1177.       *--  RightArw, Ctrl-RightArw, DownArw, Tab, PgDn, Ctrl-End, Enter
  1178.       case ( m->n = 1 ) .or. ( m->n = 3 ) .or. ;
  1179.            ( m->n = 5 ) .or. ( m->n = 7 ) .or. ;
  1180.            ( m->n = 14) .or. ( m->n = 15)
  1181.          if ( .not. eof() )                && if not end of file
  1182.             skip 1                         && move forward one record
  1183.          endif
  1184.          if ( eof() )                      && if we're now at the EOF,
  1185.             goto bottom                    && go back to last record...
  1186.          endif
  1187.  
  1188.       *-- go to toP of database, Ctrl-PgUp
  1189.       case ( m->n = 34 )
  1190.          goto top
  1191.  
  1192.       *-- go to BOTtoM of database, Ctrl-PgDn
  1193.       case ( m->n = 35 )
  1194.          goto bottom
  1195.  
  1196.    endcase
  1197.  
  1198. RETURN
  1199. *-- EoP: FileMove
  1200.  
  1201. FUNCTION Used
  1202. *----------------------------------------------------------------------
  1203. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1204. *-- Date........: 02/28/1992
  1205. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1206. *--               from DBA Magazine (11/91) calls a function that
  1207. *--               checks to see if a DBF file is open ...
  1208. *-- Written for.: dBASE IV, 1.5
  1209. *-- Rev. History: 05/15/1992 -- Original
  1210. *--               02/08/1993 -- Discovered (thanks to Jay, and then
  1211. *--               Malcolm) a much simpler way to do this ...
  1212. *-- Called by...: Any
  1213. *-- Calls.......: None
  1214. *-- Usage.......: Used("<cFile>")
  1215. *-- Example.....: if used("Library")
  1216. *--                  select library
  1217. *--               else
  1218. *--                  select select()
  1219. *--                  use library
  1220. *--               endif
  1221. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1222. *-- Parameters..: cFile = file to check for
  1223. *----------------------------------------------------------------------
  1224.  
  1225.    parameters cFile
  1226.  
  1227. RETURN (select(cFile) # 0)
  1228. *-- EoF: Used()
  1229.  
  1230. FUNCTION MDXbyte
  1231. *----------------------------------------------------------------------
  1232. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  1233. *-- Date........: 05/21/1992
  1234. *-- Notes.......: Sets the MDX byte in a DBF header ON or OFF.
  1235. *--               The DBF must not be open when the function is called.
  1236. *-- Written for.: dBASE IV v1.5
  1237. *-- Rev. History: 05/21/1992 -- Original
  1238. *-- Calls.......: dBASE low level file functions
  1239. *-- Called by...: Any
  1240. *-- Usage.......: MDXbyte(<cDBFpath>,<cOnOff>)
  1241. *-- Example.....: lByteSet = MDXbyte("mydbf.dbf","OFF")
  1242. *-- Returns.....: .T. if successful
  1243. *-- Parameters..: cDBFpath = the [path]filename.ext of the DBF
  1244. *--               cOnOff   = "ON" or "OFF"
  1245. *----------------------------------------------------------------------
  1246.  
  1247.    parameters cDBFpath,cOnOff
  1248.    private all
  1249.  
  1250.    cOnOff = upper(m->cOnOff)
  1251.    * check the validity of the parameters
  1252.    lSuccess = ( pcount() = 2 .AND. m->cOnOff $ "ON|OFF" .AND. ;
  1253.                 file(m->cDBFpath) )
  1254.    if lSuccess
  1255.       nHandle = fopen(m->cDBFpath,"RW")
  1256.       if m->nHandle > 0
  1257.          if fseek(m->nHandle, 28) = 28
  1258.             lSuccess = ( fwrite(m->nHandle, iif(m->cOnOff="OFF",;
  1259.                                                   chr(0),chr(1))) = 1 )
  1260.          else
  1261.             lSuccess = .F.
  1262.          endif
  1263.          lClosed = fclose(m->nHandle)
  1264.       else
  1265.          lSuccess = .F.
  1266.       endif
  1267.    endif
  1268.  
  1269. RETURN m->lSuccess
  1270. *-- Eof() MDXbyte
  1271.  
  1272. FUNCTION aDir
  1273. *----------------------------------------------------------------------
  1274. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  1275. *-- Date........: 02/22/1993
  1276. *-- Notes.......: aDir() creates a public array gaDir[ n, 5 ]
  1277. *--               containing directory information. gaDir[ n, 5 ] is
  1278. *--               limited to 234 rows (files) or less, depending on
  1279. *--               memory available.
  1280. *--
  1281. *--                     Structure of 2D array gaDir[ n, 5 ]:
  1282. *--
  1283. *--                     Col  Contents             Type       Width
  1284. *--                     ------------------------------------------
  1285. *--                       1  File Name            Character     12
  1286. *--                       2  Date (mm/dd/yy)      Date           8
  1287. *--                       3  Time (hh:mm:ss)      Character      8
  1288. *--                       4  Size (bytes)         Numeric       10
  1289. *--                       5  Attributes           Character      6
  1290. *--
  1291. *--               aDir() makes use of SEARCH.BIN, and credit is due its
  1292. *--               author (Roland Boucherau, Borland Technical Support). 
  1293. *--               See SEARCH.ASM or SEARCH.TXT source for details.
  1294. *--               *****************************
  1295. *--               **** REQUIRES SEARCH.BIN ****
  1296. *--               *****************************
  1297. *-- Written for.: dBASE IV, v1.5
  1298. *-- Rev. History: 07/24/1992 -- Original Release
  1299. *--               02/22/1993 -- Minor Update to PRIVATE call.
  1300. *-- Calls.......: None
  1301. *-- Called by...: Any
  1302. *-- Usage.......: adir( <cFMask>, <cBINpath>, <cAttr> )
  1303. *-- Examples....: nFiles = adir( "d:\app\fu*.db?", ;
  1304. *--                              "d:\dbase4\library\", "" )
  1305. *--               nFiles = adir( cPathSkel )
  1306. *--               nFiles = adir( "c:\*.*", "", "RHSD" )
  1307. *-- Returns.....: Number of matching files found: rows in gaDir[]
  1308. *-- Parameters..: cPathSkel = directory path and file skeleton that you
  1309. *--                           want, like DOS DIR command. Wildcards OK.
  1310. *--               cBINpath  = Optional path to Search.Bin. If omitted,
  1311. *--                           Search.Bin must be in current
  1312. *--                           subdirectory. Include the trailing "\".
  1313. *--               cAttr     = Optional file attribute mask string.
  1314. *--
  1315. *--                             Mask Codes
  1316. *--                            ------------
  1317. *--                            R - Read Only
  1318. *--                            H - Hidden
  1319. *--                            S - System
  1320. *--                            D - Directory
  1321. *--                            V - Volume
  1322. *--                            A - Archive
  1323. *--
  1324. *--               If cAttr is omitted, null, or blank, gaDir[] will
  1325. *--               contain only 'ordinary' files, i.e. files without
  1326. *--               HSDV attributes. If V is specified in the mask,
  1327. *--               ONLY volume labels are matched. Any other attribute
  1328. *--               or combination of attributes results in those files
  1329. *--               AND ordinary files being matched.
  1330. *----------------------------------------------------------------------
  1331.  
  1332.    parameters cPathSkel, cBINpath, cAttr
  1333.    private cModule,cAttr,cFSkel,cFName,cFDate,cFTime,cFSize,cFAttr,;
  1334.            nMaxRows,m->nFCount,nResult,n
  1335.  
  1336.    cModule = iif( pcount() >= 2, ;
  1337.              m->cBINpath + "search.bin", "search.bin" )
  1338.    store upper( iif( pcount() >= 3, ;
  1339.          left( m->cAttr + "      ", 6 ), "      " ) ) ;
  1340.          to cAttr, cFAttr
  1341.    cFSkel = left(m->cPathSkel + space(12), max(len(m->cPathSkel),12))
  1342.    cFName = m->cFSkel
  1343.    * ( memory() * 3.4 ) is just a GUESS on max rows before
  1344.    * 'Insufficient Memory' occurs
  1345.    nMaxRows = min( memory() * 3.4, 234 )  && 234 is absolute maximum
  1346.    nFCount = 0
  1347.    load ( m->cModule )
  1348.    nResult = call( "Search", 1, m->cFName, m->cAttr )
  1349.    if m->nResult = 0
  1350.       do while m->nResult = 0 .and. m->nFCount <= m->nMaxRows
  1351.          nFCount = m->nFCount + 1
  1352.          nResult = call( "Search" , 2, m->cFName )
  1353.       enddo
  1354.       nFCount = min( m->nMaxRows, m->nFCount )
  1355.       release gaDir
  1356.       public array gaDir[ m->nFCount, 5 ]
  1357.       cFName = m->cFSkel
  1358.       cFDate = "  /  /  "
  1359.       cFTime = "  :  :  "
  1360.       nFSize = 0
  1361.       n = 1
  1362.       nResult = ;
  1363.       call( "Search", 1, m->cFName, m->cFAttr, m->cFDate, ;
  1364.                          m->cFTime, m->nFSize )
  1365.       do while m->nResult = 0 .AND. m->n <= m->nFCount
  1366.          store m->cFName to         gaDir[ m->n, 1 ]
  1367.          store ctod( m->cFDate ) to gaDir[ m->n, 2 ]
  1368.          store m->cFTime to         gaDir[ m->n, 3 ]
  1369.          store m->nFSize to         gaDir[ m->n, 4 ]
  1370.          store m->cFAttr to         gaDir[ m->n, 5 ]
  1371.          nResult = call( "Search", 2, m->cFName, m->cFAttr, ;
  1372.                            m->cFDate, m->cFTime, m->nFSize )
  1373.          n = m->n + 1
  1374.       enddo
  1375.    else
  1376.       release gaDir
  1377.    endif
  1378.    release module Search
  1379.  
  1380. RETURN m->nFCount
  1381. *-- EoF: aDir()
  1382.  
  1383. FUNCTION DbfDir
  1384. *----------------------------------------------------------------------
  1385. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  1386. *-- Date........: 07/03/1992
  1387. *-- Notes.......: DbfDir() creates or OVERWRITES DbfDir.Dbf, and
  1388. *--               populates it with directory information. The function
  1389. *--               uses the DOS 5.0 DIR command and requires DOS 5.0.
  1390. *--
  1391. *--                          Structure of DBFDIR.DBF
  1392. *--                          -----------------------
  1393. *--                          Field    Type  Len  Dec
  1394. *--                          F_NAME      C   12    0
  1395. *--                          F_DATE      D    8    0
  1396. *--                          F_TIME      C    8    0
  1397. *--                          F_SIZE      N   10    0
  1398. *--               *************************************************
  1399. *--               *    DO NOT CALL THIS ROUTINE WHILE PRINTING    *
  1400. *--               *   (the function uses Print Redirection ...)   *
  1401. *--               *************************************************
  1402. *-- Written for.: dBASE IV v1.5, DOS 5.0
  1403. *-- Rev. History: 07/03/1992 -- Original
  1404. *-- Calls.......: TempName()           Function in FILES.PRG
  1405. *-- Called by...: None
  1406. *-- Usage.......: DbfDir( "<cPathSkel>", <lHidSys> )
  1407. *-- Examples....: nFiles = DbfDir( "*.dbf" )
  1408. *--               nFiles = DbfDir( "*.dbf", .t. )
  1409. *-- Returns.....: Number of matching files found: reccount() of DbfDir
  1410. *-- Parameters..: cPathSkel = directory path and file skeleton that you
  1411. *--                           want, like DOS DIR command. Wildcards OK.
  1412. *--               lHidSys   = Optional. If .t., hidden & system files
  1413. *--                           are included.
  1414. *----------------------------------------------------------------------
  1415.  
  1416.    parameters cPathSkel, lHidSys
  1417.    private all
  1418.  
  1419.    cDBTMP = ""
  1420.    cTmpFile = tempname( "txt", .t. ) + ".txt"
  1421.    cTmpFile = iif(""=cDBTMP, m->cTmpFile, cDBTMP + "\" + m->cTmpFile)
  1422.    cDirParms = iif( m->lHidSys, "/B/A-D/ON", "/B/A-D-H-S/ON" )
  1423.    run dir &cPathSkel. &cDirParms. > &cTmpFile.
  1424.    nFiles = 0
  1425.    if fsize( m->cTmpFile ) > 0
  1426.       lSafeOn = ( set( "safety" ) = "ON" )
  1427.       set safety off
  1428.       set printer to file DbfDir.dbf  && create DbfDir.dbf
  1429.       set printer on
  1430.       * first byte of header - various bit flags
  1431.       ??? "{3}"
  1432.       * next 3 bytes - file date in binary YYMMDD
  1433.       ??? chr(year(date())-1900)+chr(month(date()))+chr(day(date()))
  1434.       * the rest of the header, field descriptors, and records if any
  1435.       ??? "{0}{0}{0}{0}{161}{0}{39}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1436.           "{0}{0}{0}{0}{0}{0}{0}{0}{0}{1}{1}{70}{95}{78}{65}{77}"+;
  1437.           "{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{12}{0}{0}{0}{0}{0}"+;
  1438.           "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{68}{65}{84}{69}"+;
  1439.           "{0}{0}{0}{0}{0}{68}{0}{0}{0}{0}"
  1440.       ??? "{8}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}"+;
  1441.           "{84}{73}{77}{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{8}{0}{0}"+;
  1442.           "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{83}{73}"+;
  1443.           "{90}{69}{0}{0}{0}{0}{0}{78}{0}{0}{0}{0}{10}{0}{0}{0}{0}"+;
  1444.           "{0}{0}{0}{0}{0}{0}{0}{0}"
  1445.       ??? "{0}{0}{0}{13}{26}"
  1446.       set printer to
  1447.       set printer off
  1448.       cAlias = alias()
  1449.       select select()
  1450.       use DbfDir
  1451.       append from ( m->cTmpFile ) sdf
  1452.       goto top
  1453.       cPath = parspath( m->cPathSkel )
  1454.       scan
  1455.          replace f_size with fsize( cPath + f_name ),;
  1456.                  f_date with fdate( cPath + f_name ),;
  1457.                  f_time with ftime( cPath + f_name )
  1458.       endscan
  1459.       nFiles = reccount()
  1460.       use
  1461.       if lSafeOn
  1462.          set safety on
  1463.       endif
  1464.       if "" # m->cAlias
  1465.          select ( m->cAlias )
  1466.       endif
  1467.    endif
  1468.    erase ( m->cTmpFile )
  1469.  
  1470. RETURN m->nFiles
  1471. *-- EoF: DBFDir()
  1472.  
  1473. FUNCTION ParsPath
  1474. *----------------------------------------------------------------------
  1475. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  1476. *-- Date........: 07/16/1992
  1477. *-- Notes.......: ParsPath() extracts and returns the path from a
  1478. *--               full path file specification.
  1479. *-- Written for.: dBASE IV v1.1
  1480. *-- Rev. History: 07/16/1992 -- Original
  1481. *-- Calls.......: None
  1482. *-- Called by...: Any
  1483. *-- Usage.......: ParsePath( "<cFullPath>" )
  1484. *-- Example.....: set fullpath on
  1485. *--               cDBF = dbf()
  1486. *--               cPath = ParsPath( cDBF )
  1487. *-- Returns.....: The path only, including the trailing backslash,
  1488. *--               of the full path file specification
  1489. *-- Parameters..: cFullPath = a full path file spec,
  1490. *--               e.g. "c:\dbase\dbase.exe"
  1491. *----------------------------------------------------------------------
  1492.  
  1493.    parameter cFullPath
  1494.    private all
  1495.  
  1496.    cPath = ""
  1497.    if "\" $ m->cFullPath
  1498.       nPos = 1
  1499.       do while left( right ( m->cFullPath, m->nPos ), 1 ) # "\"
  1500.          nPos = m->nPos + 1
  1501.       enddo
  1502.       cPath = substr(m->cFullPath, 1, len(m->cFullPath) - m->nPos + 1)
  1503.    endif
  1504.  
  1505. RETURN cPath
  1506. *-- EoF: ParsPath()
  1507.  
  1508. PROCEDURE TagPop
  1509. *----------------------------------------------------------------------
  1510. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1511. *-- Date........: 06/30/1993
  1512. *-- Notes.......: Used to bring up a list of MDX tags on screen for the
  1513. *--               user, so they can change the current tag ... This is
  1514. *--               based on an article by Susan Perschke and Mike
  1515. *--               Liczbanski in "Data Based Advisor", December, 1991,
  1516. *--               and another by Malcom C. Rubel, Data Based Advisor,
  1517. *--               September, 1992.
  1518. *--               The idea is to bring up a picklist of all MDX tags
  1519. *--               for the current database file, showing the tag name,
  1520. *--               and expression, as well as whether or not it's
  1521. *--               unique, has a FOR clause, and whether it's ascending
  1522. *--               or descending ...
  1523. *--               However, as an additional bonus, if the user selects
  1524. *--               one of the MDX tags, the current tag is changed to
  1525. *--               the one the user selects. The tag with a "*" by it is
  1526. *--               the current tag.
  1527. *-- Written for.: dBASE IV, 1.5
  1528. *-- Rev. History: 09/08/1992 -- Version 1
  1529. *--               09/21/1992 -- Version 1.1 -- added more docs and
  1530. *--                             removed reference to parameters of
  1531. *--                             which there are none ... (changed
  1532. *--                             my mind)
  1533. *--               06/30/1993 -- Version 2 -- 3-D look and feel, added
  1534. *--                             color parameter back in, size of dialog
  1535. *--                             box changes based on # of .MDX tags in
  1536. *--                             file, and optional parameter ...
  1537. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1538. *--               CENTER               Procedure in PROC.PRG
  1539. *--               BORD3D               Procedure in PROC.PRG
  1540. *--               COLORBRK()           Function in PROC.PRG
  1541. *--               RECOLOR              Procedure in PROC.PRG
  1542. *-- Called by...: Any
  1543. *-- Usage.......: DO TagPop [with <cColor>[,<cCurTag>]]
  1544. *-- Example.....: ON KEY LABEL F8 DO TagPop with "","TITLE"
  1545. *-- Returns.....: None (well, ok -- it resets MDX tag if you select 1)
  1546. *-- Parameters..: cColor  = optional color parameter ...
  1547. *--               cCurTag = optional -- "current" tag for those
  1548. *--                         routines where, perhaps, the tag is not
  1549. *--                         "currently" active, but programmer may need
  1550. *--                         one as the "current" tag.
  1551. *----------------------------------------------------------------------
  1552.  
  1553.    parameters cColor,cCurTag
  1554.    private nBar, cPrompt, cBorder, cTag, nTag, nTagTotal, cFor, ;
  1555.            cUnique, cDir, cKey, cTemp1, cTemp2, cOldCol
  1556.  
  1557.    *-- if no colors passed, use Borland "steel grey" look
  1558.    if pCount() = 0
  1559.       cColor = "n/w,w+/n,n/w"
  1560.    else
  1561.       if isblank(m->cColor)
  1562.          cColor = "n/w,w+/n,n/w"
  1563.       endif
  1564.    endif
  1565.  
  1566.    *-- deal with cCurTag
  1567.    if pCount() < 2
  1568.       cCurTag = trim(order())
  1569.    else
  1570.       cCurTag = trim(upper(m->cCurTag))  && just to be sure
  1571.    endif
  1572.  
  1573.    *-- Disable left/right arrow keys to prevent an accidental exit
  1574.    on key label leftarrow  ?? chr(7)
  1575.    on key label rightarrow ?? chr(7)
  1576.  
  1577.    *-- Save current screen
  1578.    save screen to sTag
  1579.    cBorder = set("BORDER")
  1580.    activate screen
  1581.  
  1582.    *-- determine number of tags in current .MDX
  1583.    nTags = tagcount()
  1584.  
  1585.    *-- define the screen/window
  1586.    nTop    = 5
  1587.    nLeft   = 2
  1588.    nBottom = m->nTop + iif(m->nTags > 4, m->nTags, 4) + 12
  1589.    nBottom = iif(m->nBottom > 22, 22, m->nBottom)
  1590.    nRight  = 77
  1591.    define window wTagPop from m->nTop,m->nLeft to m->nBottom,m->nRight;
  1592.       NONE color &cColor.
  1593.    activate screen
  1594.    do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight
  1595.    activate window wTagPop
  1596.    do bord3d with 0,0,m->nBottom-m->nTop,m->nRight-m->nLeft,;
  1597.       colorbrk(m->cColor,1),1
  1598.  
  1599.    *-- check to see if there are any tags ... or an active database ...
  1600.    if isblank(alias()) .or. isblank(tag(1))
  1601.  
  1602.       *-- if not, display appropriate error message
  1603.       if isblank(alias())
  1604.          do center with 2,75,"","** No active Database ... **"
  1605.       else
  1606.          do center with 2,75,"",;
  1607.             "** No active .MDX file for this .DBF **"
  1608.       endif
  1609.       x=inkey(0)  && wait for user to press a key ...
  1610.  
  1611.    else   && we DO have an active database AND active MDX file
  1612.  
  1613.       *-- headings
  1614.       cTextCol = colorbrk(m->cColor,1)
  1615.       do center with 1,75,m->cTextCol," Select new MDX Tag "
  1616.       @3, 4 say "Name" color &cTextCol.
  1617.       @3,13 say "For"  color &cTextCol.
  1618.       @3,17 say "Unq"  color &cTextCol.
  1619.       @3,21 say "Seq"  color &cTextCol.
  1620.       @3,25 say "Expression" color &cTextCol.
  1621.       do bord3d with 2,3,4,72,colorbrk(m->cColor,1),3
  1622.  
  1623.       *-- popup will display here
  1624.  
  1625.       *-- footings (as it were)
  1626.       nBotLine = nBottom-nTop
  1627.       nLine = nBotLine-6
  1628.       do bord3d with m->nLine,3,m->nLine+4,72,colorbrk(m->cColor,1),4
  1629.       @nLine+1,5 say chr(251)+;
  1630.          " in 'For' column means there is a 'For' clause";
  1631.          color &cTextCol.
  1632.       @nLine+2,5 say chr(251)+;
  1633.          " in 'Unq' column means the tag is set to 'Unique'";
  1634.          color &cTextCol.
  1635.       @nLine+3,5 say chr(24)+;
  1636.          " in 'Seq' means tag is 'Ascending', "+;
  1637.          chr(25)+" means tag is 'Descending'" color &cTextCol.
  1638.  
  1639.       *-- define the popup
  1640.       set border to none  && no border for popup
  1641.       nPopTop    = 4
  1642.       * account for "border" even if there is none
  1643.       nPopBottom = iif(m->nTags > 7, 9, m->nPopTop + m->nTags) + 1
  1644.       define popup pTag from m->nPopTop,3 to m->nPopBottom,72 message ;
  1645.          " Press ENTER to select new index order ... ESC to exit ..."
  1646.       nBar = 1                        && first bar
  1647.       *-- place a * if no tag is currently active
  1648.       cPrompt = iif((TagNo()=0) .and. isblank(m->cCurTag),"*"," ")+;
  1649.          " No Index"  && bar 1 will always be this
  1650.       cPrompt = m->cPrompt + space(11)+"(Natural Order)"
  1651.       nTag = 0
  1652.  
  1653.       *-- loop to get the rest of 'em ...
  1654.       nTagTotal = tagcount()             && get total number of tags
  1655.       do while m->nTag <= m->nTagTotal   && loop until no more tags
  1656.          define bar nBar of pTag prompt (m->cPrompt)
  1657.          nTag = m->nTag + 1
  1658.          cDefault = iif( (trim(tag(m->nTag)) = m->cCurTag) .and.;
  1659.                          .not. isblank(m->cCurTag),;
  1660.                          "*"," ")   && if current tag ...
  1661.          *-- the fun part is getting the spacing "just right"
  1662.          *-- that's what all the IIF( ....,space(...)) stuff is about
  1663.          cTag    = tag(m->nTag) + iif(len(tag(m->nTag)) < 9, ;
  1664.                    space(9-len(tag(m->nTag))),"")
  1665.          cFor    = iif(isblank(for(m->nTag))," ",chr(251))
  1666.          cUnique = iif(unique(m->nTag),chr(251)," ")
  1667.          cDir    = iif(descending(m->nTag),chr(25),chr(24))
  1668.                    && up/down arrows ...
  1669.          cKey    = iif(len(key(m->nTag))>57,left(key(m->nTag),52)+;
  1670.                    " ...",key(m->nTag))
  1671.          cKey    = iif(len(m->cKey)<57,m->cKey + ;
  1672.                    space(57-len(m->cKey)),m->cKey)
  1673.          *-- here's the actual definition of the bars ...
  1674.          cPrompt = m->cDefault + m->cTag + "  " + m->cFor + "  " + ;
  1675.                    m->cUnique  + "  " + m->cDir + "  " + m->cKey
  1676.          nBar = m->nBar + 1
  1677.       enddo
  1678.  
  1679.       *-- turn it off when an item has been selected or <Esc> pressed
  1680.       on selection popup pTag deactivate popup
  1681.  
  1682.       *-- do it
  1683.       cOldCol = set("ATTRIBUTE")
  1684.       cTemp1 = colorbrk(m->cColor,1)
  1685.       cTemp2 = colorbrk(m->cColor,2)
  1686.       set color of message to &cTemp1.
  1687.       set color of box to &cTemp1.
  1688.       set color of highlight to &cTemp2.
  1689.       activate popup pTag
  1690.  
  1691.       *-- Don't change index order if ESC pressed
  1692.       if bar() <> 0
  1693.          *-- Assign a null string to cPrompt if "No Index" selected
  1694.          cPrompt = iif(bar() = 1, "",tag(bar()-1))
  1695.          set order to (m->cPrompt)
  1696.       endif
  1697.  
  1698.       *-- cleanup
  1699.       do recolor with m->cOldCol
  1700.       release popup pTag
  1701.       set border to &cBorder.
  1702.  
  1703.    endif
  1704.    release window wTagPop
  1705.    restore screen from sTag
  1706.    release screen sTag
  1707.  
  1708.    *-- re-enable left/right arrow keys
  1709.    on key label leftarrow
  1710.    on key label rightarrow
  1711.  
  1712. RETURN
  1713. *-- EoP: TagPop
  1714.  
  1715. FUNCTION AAppend
  1716. *----------------------------------------------------------------------
  1717. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1718. *-- Date........: 10/26/1993
  1719. *-- Notes.......: Appends a text file into an array. This routine is
  1720. *--               limited to text files of 1,170 lines, and 254 char-
  1721. *--               acters per line. The text file must be an ASCII Txt
  1722. *--               formatted file. Taken from Technotes, April, 1992.
  1723. *-- Written for.: dBASE IV, 1.5
  1724. *-- Rev. History: 04/01/1992 -- Original
  1725. *--             : 10/26/1993 Angus Scott-Fleming release "ALL LIKE"
  1726. *-- Calls.......: TextLine()           Function in FILES.PRG
  1727. *-- Called by...: Any
  1728. *-- Usage.......: AAppend(<cFileName>,<aArrayName>)
  1729. *-- Example.....: ?AAppend("CONFIG.DB","aConfig")
  1730. *-- Returns.....: .T.
  1731. *-- Parameters..: cFileName  = Name of DOS Text file to read into array
  1732. *--               aArrayName = Name of array to create. If it already
  1733. *--                            exists, this array will be destroyed and
  1734. *--                            overwritten.
  1735. *----------------------------------------------------------------------
  1736.  
  1737.    parameters cFileName, aArrayName
  1738.    private aTArray, nLines, nX, nHandle
  1739.  
  1740.    *-- assign array name to a temp variable name ...
  1741.    aTArray = m->aArrayName
  1742.    *-- if it exists, get rid of it, and then re-define it
  1743.    *-- Tue  10-26-1993  original code release &aTArray. wasn't working
  1744.    release all like &aTArray.
  1745.    aTArray = m->aArrayName
  1746.    public  &aTArray.
  1747.    nLines = TextLine(m->cFileName)  && get number of lines
  1748.    declare &aTArray.[min(m->nLines,1170)]
  1749.  
  1750.    *-- get file handle
  1751.    nHandle = fopen(m->cFileName)
  1752.  
  1753.    *-- store the file into the array
  1754.    nX = 1
  1755.    do while m->nX <= m->nLines
  1756.       store fgets(m->nHandle,254) to &aTArray.[m->nX]
  1757.       nX = m->nX + 1
  1758.    enddo
  1759.  
  1760.    *-- close the file
  1761.    nHandle = fClose(m->nHandle)
  1762.  
  1763. RETURN .T.
  1764. *-- EoF: AAppend()
  1765.  
  1766. FUNCTION FDel
  1767. *----------------------------------------------------------------------
  1768. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1769. *-- Date........: 04/01/1992
  1770. *-- Notes.......: Deletes a given portion of a file. Taken from
  1771. *--               TechNotes, April, 1992
  1772. *--               Used to delete a portion of a file (text or binary)
  1773. *--               from the beginning of the file, the end of file or
  1774. *--               current pointer position. This routine accomplishes
  1775. *--               its task by writing the data you want to keep to a
  1776. *--               temp file, then overwriting the data you no longer
  1777. *--               want with the temp file. If you are on a network,
  1778. *--               make sure that you set TMP (or DBTMP) to either a
  1779. *--               local drive, or one where you have full rights.
  1780. *-- Written for.: dBASE IV, 1.5
  1781. *-- Rev. History: 04/01/1992 -- Original
  1782. *-- Calls.......: TempFile()           Function in FILES.PRG
  1783. *-- Called by...: Any
  1784. *-- Usage.......: FDel(<nHandle>,<nBytes>,<nStart>)
  1785. *-- Example.....: nOpen = fopen("TEXT.TXT","RW")
  1786. *--               ?FDel(nOpen,1000,1)
  1787. *-- Returns.....: Logical
  1788. *-- Parameters..: nHandle = file handle number, as returned by FOPEN
  1789. *--               nBytes  = number of chars (bytes) to delete in file
  1790. *--               nStart  = starting position, where:
  1791. *--                          0 is the beginning of the file
  1792. *--                          1 is the current file pointer position
  1793. *--                          2 is the end of the file
  1794. *----------------------------------------------------------------------
  1795.  
  1796.    parameters nHandle, nBytes, nStart
  1797.    private nTemp,cTemp,nSave,nSeek,nRead,nWrite,lFlush,nClose
  1798.  
  1799.    *-- create a temporary file
  1800.    cTemp = tempfile("ADM")
  1801.    *-- save current position in file
  1802.    nSave = fseek(m->nHandle,0,1)
  1803.  
  1804.    do case
  1805.    case m->nStart = 0                  && beginning of file
  1806.       nSeek = fseek(m->nHandle, m->nBytes, 0)
  1807.       nTemp = fcreate(m->cTemp)
  1808.       do while .not. feof(m->nHandle)
  1809.          nRead = fread(m->nHandle,254)
  1810.          nWrite = fwrite(m->nTemp,m->nRead)
  1811.          lFlush = fflush(m->nTemp)
  1812.       enddo
  1813.       nSeek = fseek(m->nTemp,0,0)
  1814.       nSeek = fseek(m->nHandle,0,0)
  1815.       do while .not. feof(m->nTemp)
  1816.          nRead = fread(m->nTemp,254)
  1817.          nWrite = fwrite(m->nHandle,m->nRead)
  1818.          lFlush = fflush(m->nHandle)
  1819.       enddo
  1820.       nWrite = fwrite(m->nHandle,chr(0),0)
  1821.       nClose = fclose(m->nTemp)
  1822.       nSeek = fseek(m->nHandle,m->nSave,0)
  1823.  
  1824.    case m->nStart = 1                  && Current Location
  1825.       *-- skip these bytes
  1826.       nSeek = fseek(m->nHandle,m->nDelete,1)
  1827.       *-- write the rest to a temp file
  1828.       nTemp=fCreate(m->cTemp)
  1829.       do while .not. feof(m->nHandle)
  1830.          nRead = fread(m->nHandle,254)
  1831.          nWrite = fwrite(m->nTemp,m->nRead)
  1832.          lFlush = fflush(m->nTemp)
  1833.       enddo
  1834.  
  1835.       nSeek = fseek(m->nTemp,0,0)
  1836.       nSeek = fseek(m->nHandle,m->nSave,0)
  1837.       nWrite = fwrite(m->nHandle,chr(0),0)
  1838.  
  1839.       do while .not. feof(m->nTemp)
  1840.          nRead = fread(m->nTemp,254)
  1841.          nWrite = fwrite(m->nHandle,m->nRead)
  1842.          lFlush = fflush(m->nHandle)
  1843.       enddo
  1844.       nSeek = fseek(m->nHandle,m->nSave,0)
  1845.       nClose = fclose(m->nTemp)
  1846.  
  1847.    case m->nStart = 2                  && End of File
  1848.       nSeek = fseek(m->nHandle,-1*abs(m->nDelete),2)
  1849.       nWrite = fwrite(m->nHandle,chr(0),0)
  1850.    endcase
  1851.    erase (m->cTemp)
  1852.  
  1853. RETURN (ferror() = 0)
  1854. *-- EoF: FDel()
  1855.  
  1856. FUNCTION FGetLine
  1857. *----------------------------------------------------------------------
  1858. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1859. *-- Date........: 04/01/1992
  1860. *-- Notes.......: Used to extract a line of text from a text file. 
  1861. *-- Written for.: dBASE IV, 1.5
  1862. *-- Rev. History: 04/01/1992 -- Original
  1863. *-- Calls.......: TLine()              Function in FILES.PRG
  1864. *--               TLineNo()            Function in FILES.PRG
  1865. *-- Called by...: Any
  1866. *-- Usage.......: FGetLine(<cFileName>,<cLookup>,[<lCase>],[<lEntire>])
  1867. *-- Example.....: ?FGetLine("config.db","command",.f.,.f.)
  1868. *-- Returns.....: A character expression
  1869. *-- Parameters..: cFileName = Name of file to extract text from
  1870. *--               cLookup   = Text to look for
  1871. *--               lCase     = Case sensitive? (Logical = .t. or .f.)
  1872. *--                           If empty, default is .F.
  1873. *--               lEntire   = Return entire line, or the rest of line
  1874. *--                           .t. = return the entire line
  1875. *--                           .f. = return everything following cLookup
  1876. *--                           If empty, default is .t.
  1877. *----------------------------------------------------------------------
  1878.  
  1879.    parameters cFileName, cLookup, lCase, lEntire
  1880.    private nLine, cText
  1881.  
  1882.    *-- defaults
  1883.    lCase   = iif(pcount() <= 2,.f.,m->lCase)
  1884.    lEntire = iif(pcount() <=3,.t.,m->lEntire)
  1885.    *-- get the line ...
  1886.    nLine = TLineNo(m->cFile,m->cLookup,m->lCase)
  1887.    cText = iif(m->nLine<=0,"",TLine(m->cFile,m->nLine,m->lCase))
  1888.    cResult = upper(m->cText)
  1889.  
  1890. RETURN iif( m->lEntire, m->cText, ;
  1891.    substr(m->cText,at(upper(m->cLookup),m->cResult)+len(m->cLookup)) )
  1892. *-- EoF: FGetLine()
  1893.  
  1894. FUNCTION FIns
  1895. *----------------------------------------------------------------------
  1896. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1897. *-- Date........: 04/01/1992
  1898. *-- Notes.......: Inserts specified number of NULLS into a low-level
  1899. *--               file. Taken from Technotes, April, 1992. FIns() works
  1900. *--               the way FDel() works, but in reverse.  See comments
  1901. *--               in FDel about temp directory ...
  1902. *-- Written for.: dBASE IV, 1.5
  1903. *-- Rev. History: 04/01/1992 -- Original
  1904. *-- Calls.......: TempFile()           Function in FILES.PRG
  1905. *-- Called by...: Any
  1906. *-- Usage.......: FIns(<nHandle>,<nBytes>,<nStart>)
  1907. *-- Example.....: nOpen = fopen("TEST.TXT","RW")
  1908. *--               ?FIns(nOpen,10,1)
  1909. *-- Returns.....: Logical
  1910. *-- Parameters..: nHandle = File Handle from FOPEN() function
  1911. *--               nBytes  = Number of nulls to insert into file
  1912. *--               nStart  = Location in file to start at, where:
  1913. *--                         0 = Beginning of file
  1914. *--                         1 = Current file pointer
  1915. *--                         2 = End of file
  1916. *----------------------------------------------------------------------
  1917.  
  1918.    parameters nHandle, nBytes, nStart
  1919.    private nTemp, cTemp, nSave, nRead, nWrite, nSeek, lFlush, nX,nClose
  1920.  
  1921.    cTemp = TempFile("ADM")      && create temp file
  1922.    nSave = fseek(m->nHandle,0,1)   && save current position
  1923.  
  1924.    do case
  1925.       case m->nStart = 0           && beginning of file
  1926.          nTemp = fcreate(m->cTemp)
  1927.          nX = 1
  1928.          do while m->nX <= m->nBytes
  1929.             nWrite = fwrite(m->nTemp,chr(0),1)
  1930.             nX = m->nX + 1
  1931.          enddo
  1932.          nSeek = fseek(m->nHandle,0,0)
  1933.          do while .not. feof(m->nHandle)
  1934.             nRead = fread(m->nHandle,254)
  1935.             nWrite = fwrite(m->nTemp,m->nRead)
  1936.             lFlush = fflush(m->nTemp)
  1937.          enddo
  1938.          nSeek = fseek(m->nTemp,0,0)
  1939.          nSeek = fseek(m->nHandle,0,0)
  1940.          do while .not. feof(m->nTemp)
  1941.             nRead = fread(m->nTemp,254)
  1942.             nWrite = fwrite(m->nHandle,m->nRead)
  1943.             lFlush = fflush(m->nHandle)
  1944.          enddo
  1945.          nWrite = fwrite(m->nHandle,chr(0),0)
  1946.          nclose = fclose(m->ntemp)
  1947.          nSeek = fseek(m->nHandle,0,0)
  1948.  
  1949.       case m->nStart = 1                  && current location
  1950.          *-- write the rest to a temp file
  1951.          nTemp = fcreate(m->cTemp)
  1952.          do while .not. feof(m->nHandle)
  1953.             nRead = fread(m->nHandle,254)
  1954.             nWrite = fwrite(m->nTemp,m->nRead)
  1955.             lFlush = fflush(m->nTemp)
  1956.          enddo
  1957.          nSeek = fseek(m->nHandle,m->nSave,0)
  1958.          nX = 1
  1959.          do while m->nX <= m->nBytes
  1960.             nWrite = fWrite(m->nHandle,chr(0),1)
  1961.             nX = m->nX + 1
  1962.          enddo
  1963.          nSeek = fseek(m->nTemp,0,0)
  1964.          do while .not. feof(m->nTemp)
  1965.             nRead = fread(m->nTemp,254)
  1966.             nWrite = fwrite(m->nHandle,m->nRead)
  1967.             lFlush = fflush(m->nHandle)
  1968.          enddo
  1969.          nSeek = fseek(m->nHandle,m->nSave,0)
  1970.          nClose = fclose(m->nTemp)
  1971.  
  1972.       case m->nStart = 2                  && End of File
  1973.          nSeek = fseek(m->nHandle,0,2)
  1974.          nX = 1
  1975.          do while m->nX <= m->nBytes
  1976.             nWrite = fwrite(m->nHandle,chr(0),1)
  1977.             nX = m->nX + 1
  1978.          enddo
  1979.    endcase
  1980.    erase (m->cTemp)
  1981.  
  1982. RETURN (ferror() = 0)
  1983. *-- EoF: FIns()
  1984.  
  1985. FUNCTION GetInfo
  1986. *----------------------------------------------------------------------
  1987. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1988. *-- Date........: 10/26/1993
  1989. *-- Notes.......: Retrieves information from STATUS that you cannot get
  1990. *--               with the dBASE IV function SET(). See 'parameters'
  1991. *--               below for list of keywords.
  1992. *--               CAUTION: If you have ALTERNATE set, you need to reset
  1993. *--               it after the function executes. SET ALTERNATE TO must
  1994. *--               be used instead of LIST STATUS TO filename, since the
  1995. *--               print destination would always show as a file. All
  1996. *--               results that are returned are returned as character
  1997. *--               types, including ones that return numbers (use VAL()
  1998. *--               to look at/use returned value as a number).
  1999. *-- Written for.: dBASE IV, 1.5
  2000. *-- Rev. History: 04/01/1992 -- Original
  2001. *--             : 10/26/1993  Angus Scott-Fleming
  2002. *--             :             replace cSafety w lSafety
  2003. *--             :             upper-case cStart
  2004. *--             :             minor bug fixes as noted by && <date>
  2005. *-- Calls.......: TempFile()       Function in FILES.PRG
  2006. *--               TextLine()       Function in FILES.PRG
  2007. *--               AAppend()        Function in FILES.PRG
  2008. *-- Called by...: Any
  2009. *-- Usage.......: GetInfo(<cKeyWord>,[<cKeyWord2>])
  2010. *-- Example.....: ? GetInfo("F5")
  2011. *-- Returns.....: Character expression
  2012. *-- Parameters..: cKeyWord  = Item you are looking for status of,
  2013. *--                           options listed return the following:
  2014. *--                    WORK    Number of current work area - whether
  2015. *--                            or not database is in use
  2016. *--                    PRINT   Current printer destination (PRN, NUL,
  2017. *--                            LPT1, COM1) as set by SET PRINTER TO.
  2018. *--                    ERROR   Error condition set by ON ERROR
  2019. *--                    ESCAPE  Escape condition set by ON ESCAPE
  2020. *--                    F2 to F10, Ctrl-F1 to Ctrl-F10, Shift-F1
  2021. *--                       to Shift-F10
  2022. *--                            The current setting of each key
  2023. *--                            as set by SET FUNCTION <label> TO
  2024. *--               OR
  2025. *--               cKeyWord, cKeyWord2 = Items you are checking the
  2026. *--                           status of, options return the following:
  2027. *--                    PAGE,LINE  Line number specified by ON PAGE AT
  2028. *--                               LINE in the page handling routine
  2029. *--                    HANDLE,<filename>  The handle number of the low-
  2030. *--                               level file specified by <filename>
  2031. *--                    NAME,<filehandle>  The file name of the low-
  2032. *--                               level file specified by <filehandle>
  2033. *--                    MODE,<filehandle>  The privilege of the low-
  2034. *--                               level file specified by <filehandle>
  2035. *----------------------------------------------------------------------
  2036.  
  2037.    parameters cKeyWord, cKeyWord2
  2038.    private cKey, l2Parms, cStart, lSafety, cTempTxt, nLines, cTmpArray
  2039.  
  2040.    cKey = upper(m->cKeyWord)
  2041.    l2Parms = (pcount() = 2)
  2042.  
  2043.    do case
  2044.       case m->cKey = "CTRL-" .or. m->cKey = "SHIFT" .or. ;
  2045.           (","+m->cKey+"," $ ",F2,F3,F4,F5,F6,F7,F8,F9,F10,")
  2046.           cStart = m->cKey + space(9 - len(m->cKey))+"-"
  2047.  
  2048.       case m->cKey = "PRINT"
  2049.          cStart = "Print Destination:"
  2050.  
  2051.       case m->cKey = "WORK"
  2052.          cStart = "Current work area ="
  2053.          if "" <> dbf()
  2054.             RETURN select(alias())
  2055.          endif
  2056.  
  2057.       case m->cKey = "ERROR"
  2058.          cStart = "On Error:"
  2059.  
  2060.       case m->cKey = "ESCAPE"
  2061.          cStart = "On Escape:"
  2062.  
  2063.       case m->cKey = "PAGE"
  2064.          cStart = "On Page At Line"
  2065.  
  2066.       case m->cKey = "HANDLE" .or. m->cKey = "NAME" .or. ;
  2067.            m->cKey = "MODE"
  2068.          cStart = "Low level files opened"
  2069.  
  2070.       otherwise      && none of the above
  2071.          RETURN ""
  2072.  
  2073.    endcase
  2074.  
  2075.    cTempTxt = TempFile()
  2076.    *-- get status info (into a temp file), which will then be parsed to
  2077.    *-- extract information requested ...
  2078.    set console off
  2079.    set alternate to &cTempTxt..  && create file without extension
  2080.                                  && double 'dot' is required
  2081.    set alternate on
  2082.    list status
  2083.    close alternate
  2084.    set console on
  2085.  
  2086.    nLines = TextLine(m->cTempTxt)
  2087.    aTmpArray = right(m->cTempTxt,8)
  2088.    cTmp = AAppend(m->cTempTxt,m->aTmpArray)
  2089.    nHandle = fopen(m->cTempTxt,"R")
  2090.    cResult = ""
  2091.  
  2092.    nX = 1
  2093.    cStart = upper(m->cStart)            && Tue  10-26-1993  upper case
  2094.    nStartLen = len(m->cStart)           && Tue  10-26-1993  pre-load LEN
  2095.    do while m->nX <= m->nLines
  2096.       if upper(left(&aTmpArray.[m->nX],m->nStartLen)) = m->cStart
  2097.          cResult = ltrim(substr(&aTmpArray.[m->nX],m->nStartLen+1))
  2098.          exit
  2099.       endif
  2100.       nX = m->nX + 1
  2101.    enddo
  2102.  
  2103.    *-- 2 parameters?
  2104.    if m->l2Parms .and. "" # m->cResult
  2105.       do case
  2106.          case m->cKey = "PAGE"
  2107.             if upper(m->cKeyWord2) = "LINE"
  2108.                cResult = left(m->cResult,at(" ",m->cResult) - 1)
  2109.             else
  2110.                cResult = substr(m->cResult,at(" ",m->cResult) + 1)
  2111.             endif
  2112.  
  2113.          case m->cKey = "HANDLE" .or. m->cKey = "NAME" .or. ;
  2114.               m->cKey = "MODE"
  2115.             cResult = ""
  2116.             nX = m->nX + 2
  2117.             do while val(&aTmpArray.[m->nX]) <> 0
  2118.                do case
  2119.                   case m->cKey = "HANDLE" .and. ;
  2120.                        upper(m->cKeyWord2) $ &aTmpArray.[m->nX]
  2121.                       cResult = str(val(&aTmpArray.[m->nX]))
  2122.  
  2123.                   case m->cKey = "NAME" .and. ;
  2124.                      m->cKeyWord2 = val(&aTmpArray.[m->nX])
  2125.                      cResult = substr(&aTmpArray.[m->nX],10,40)
  2126.  
  2127.                   case m->cKey = "MODE" .and. ;
  2128.                        m->cKeyWord2 = val(&aTmpArray.[m->nX])
  2129.                      cResult = substr(&aTmpArray.[m->nX],50,5)
  2130.                endcase
  2131.                if "" <> m->cResult
  2132.                   exit
  2133.                endif
  2134.                nX = m->nX + 1
  2135.             enddo
  2136.       endcase
  2137.    endif
  2138.  
  2139.    release &aTmpArray.
  2140.    nClose = fclose(m->nHandle)
  2141.    lSafety = set ("safety") = "ON"     && Tue  10-26-1993
  2142.    set safety off
  2143.    erase (m->cTempTxt + ".")
  2144.    if lSafety                           && Tue  10-26-1993  replace
  2145.       set safety ON                     && the dreaded macro expansion
  2146.    endif
  2147.    cResult = ltrim(rtrim(m->cResult))
  2148.  
  2149. RETURN iif(right(m->cResult,1) = ":",;
  2150.        left(m->cResult,len(m->cResult)-1),m->cResult)
  2151. *-- EoF: GetInfo()
  2152.  
  2153. FUNCTION TextLine
  2154. *----------------------------------------------------------------------
  2155. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2156. *-- Date........: 04/01/1992
  2157. *-- Notes.......: Returns the number of lines of text in an ASCII Text
  2158. *--               File Taken from TechNotes, April, 1992
  2159. *-- Written for.: dBASE IV, 1.5
  2160. *-- Rev. History: 04/01/1992 -- Original
  2161. *-- Calls.......: None
  2162. *-- Called by...: Any
  2163. *-- Usage.......: TextLine(<cTextFile>)
  2164. *-- Example.....: ?TextLine("CONFIG.DB")
  2165. *-- Returns.....: Number of lines
  2166. *-- Parameters..: cTextFile = name of file
  2167. *----------------------------------------------------------------------
  2168.  
  2169.    parameter cTextFile
  2170.    private nLines, nHandle, cTemp, nClose
  2171.  
  2172.    nLines = 0
  2173.    if file(m->cTextFile)   && if it exists ...
  2174.       nHandle = fopen(m->cTextFile,"R")
  2175.       do while .not. feof(m->nHandle)
  2176.          cTemp = fgets(m->nHandle,254)
  2177.          nLines = m->nLines + 1
  2178.       enddo
  2179.       nClose = fclose(m->nHandle)
  2180.    endif
  2181.  
  2182. RETURN m->nLines
  2183. *-- EoF: TextLine()
  2184.  
  2185. FUNCTION TLine
  2186. *----------------------------------------------------------------------
  2187. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2188. *-- Date........: 04/01/1992
  2189. *-- Notes.......: Returns a specific line in an ASCII Text File. This
  2190. *--               is similar to the way MLINE() works on a memo field.
  2191. *--               Taken from TechNotes April, 1992.
  2192. *-- Written for.: dBASE IV, 1.5
  2193. *-- Rev. History: 04/01/1992 -- Original
  2194. *-- Calls.......: None
  2195. *-- Called by...: Any
  2196. *-- Usage.......: TLine(<cTextFile>,<nLine>)
  2197. *-- Example.....: ?TLine("CONFIG.DB",20)
  2198. *-- Returns.....: Character expression - specified line of text file.
  2199. *-- Parameters..: cTextFile = name of text file
  2200. *--               nLine     = line to return from text file
  2201. *----------------------------------------------------------------------
  2202.  
  2203.    parameters cTextFile, nLine
  2204.    private cText, nX, nHandle, nClose
  2205.  
  2206.    cText = ""
  2207.    nX = 1
  2208.    if file(m->cTextFile)    && if file exists ...
  2209.       nHandle = fopen(m->cTextFile,"R")
  2210.       do while .not. feof(m->nHandle)
  2211.          cText = fgets(m->nHandle,254)
  2212.          if nX = m->nLine
  2213.             exit
  2214.          endif
  2215.          nX = m->nX + 1
  2216.       enddo
  2217.       nClose = fclose(m->nHandle)
  2218.    endif
  2219.  
  2220. RETURN m->cText
  2221. *-- EoF: TLine()
  2222.  
  2223. FUNCTION TLineNo
  2224. *----------------------------------------------------------------------
  2225. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2226. *-- Date........: 04/01/1992
  2227. *-- Notes.......: Returns the line number of the phrase you are
  2228. *--               searching for in an ASCII Text File. This is similar
  2229. *--               to dBASE's AT() function, but works on LINES rather
  2230. *--               than CHARACTERS. Taken from TechNotes, April, 1992
  2231. *-- Written for.: dBASE IV, 1.5
  2232. *-- Rev. History: 04/01/1992 -- Original
  2233. *-- Calls.......: None
  2234. *-- Called by...: Any
  2235. *-- Usage.......: TLineNo(<cTextFile>,<cLookup>,[<lCase>])
  2236. *-- Example.....: ?TLineNo("CONFIG.DB","command",.f.)
  2237. *-- Returns.....: numeric value (the line number containing the line
  2238. *--               needed) returns -1 if not found
  2239. *-- Parameters..: cTextFile = Name of ASCII Text File
  2240. *--               cLookup   = Text to search for ...
  2241. *--               lCase     = Case Sensitive? (Default is .F.)
  2242. *----------------------------------------------------------------------
  2243.  
  2244.    parameters cTextFile, cLookup, lCase
  2245.    private cPhrase, nHandle, cText, nX, nClose
  2246.  
  2247.    if pCount() = 3 .and. m->lCase
  2248.       lCase = .t.
  2249.       cPhrase = m->cLookup
  2250.    else
  2251.       lCase = .f.
  2252.       cPhrase = upper(m->cLookup)
  2253.    endif
  2254.  
  2255.    cText = ""
  2256.    nX = 1
  2257.    if file(m->cTextFile)
  2258.       nHandle = fopen(m->cTextFile,"R")
  2259.       do while .not. feof(m->nHandle)
  2260.          cText = fgets(m->nHandle,254)
  2261.          if at(m->cPhrase,iif(m->lCase,m->cText,upper(m->cText))) > 0
  2262.             nClose = fclose(m->nHandle)
  2263.             RETURN m->nX
  2264.          endif
  2265.          nX = m->nX + 1
  2266.       enddo
  2267.  
  2268.       nClose = fclose(m->nHandle)
  2269.    endif
  2270.  
  2271. RETURN -1
  2272. *-- EoF: TLineNo()
  2273.  
  2274. FUNCTION TempFile
  2275. *----------------------------------------------------------------------
  2276. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2277. *-- Date........: 04/01/1992
  2278. *-- Notes.......: Returns a random filename.
  2279. *-- Written for.: dBASE IV, 1.5
  2280. *-- Rev. History: 04/01/1992 -- Original
  2281. *-- Calls.......: TempDir()            Function in FILES.PRG
  2282. *-- Called by...: Any
  2283. *-- Usage.......: TempFile([cFileExt])
  2284. *-- Example.....: cVarFile = TempFile("$XY")
  2285. *-- Returns.....: Filename
  2286. *-- Parameters..: cFileExt = optional parameter - allows you to assign
  2287. *--                          file extension to the end of the filename.
  2288. *----------------------------------------------------------------------
  2289.  
  2290.    parameters cFileExt
  2291.  
  2292. RETURN TempDir()+"TMP"+right(ltrim(str(rand(-1)*10000000)),5);
  2293.        +iif(pcount() = 0 .or. "" = m->cFileExt,"","."+m->cFileExt)
  2294. *-- EoF: TempFile()
  2295.  
  2296. FUNCTION TempDir
  2297. *----------------------------------------------------------------------
  2298. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2299. *-- Date........: 04/01/1992
  2300. *-- Notes.......: Returns path of temporary directory as set from DOS
  2301. *--               (i.e., SET DBTMP= ...) Taken from TechNotes, April,92
  2302. *-- Written for.: dBASE IV, 1.5
  2303. *-- Rev. History: 04/01/1992 -- Original
  2304. *-- Calls.......: GetEnv()             Function in FILES.PRG
  2305. *-- Called by...: Any
  2306. *-- Usage.......: TempDir()
  2307. *-- Example.....: ?TempDir()
  2308. *-- Returns.....: Path of temporary directory
  2309. *-- Parameters..: None
  2310. *----------------------------------------------------------------------
  2311.  
  2312.    cTempDir = iif("" <> GetEnv("DBTMP"),GetEnv("DBTMP"),GetEnv("TMP"))
  2313.  
  2314. RETURN m->cTempDir+iif(right(m->cTempDir,1)<> "\" .and.;
  2315.        left(os(),3) = "DOS" .and. .not. "" = m->cTempDir,"\","")
  2316. *-- EoF: TempDir()
  2317.  
  2318. FUNCTION DirList
  2319. *----------------------------------------------------------------------
  2320. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2321. *-- Date........: 02/01/1993
  2322. *-- Notes.......: Used to display a popup of the hierarchical structure
  2323. *--               of directories. With this you can select a directory
  2324. *--               from the popup.
  2325. *--               DirList() returns a DOS Error Number if it encounters
  2326. *--               one, or a -1 if it fails to perform its task. It
  2327. *--               Originally Printed in TechNotes, February 1993
  2328. *--               ************************************************
  2329. *--               *** REQUIRES DOS TREE COMMAND BE IN DOS PATH ***
  2330. *--               ************************************************
  2331. *-- Written for.: dBASE IV, 1.5
  2332. *-- Rev. History: 02/01/1993 -- Original Release
  2333. *-- Calls.......: WhatDir              Procedure in FILES.PRG
  2334. *-- Called by...: Any
  2335. *-- Usage.......: DirList([<cDrive>])
  2336. *-- Example.....: ?DirList()    or
  2337. *--               ?DirList("A:")
  2338. *-- Returns.....: See above
  2339. *-- Parameters..: cDrive = Optional Parameter to list a specific drive
  2340. *--                        instead of the default.
  2341. *----------------------------------------------------------------------
  2342.  
  2343.    parameters cDrive
  2344.  
  2345.    *-- deal with possible errors
  2346.    do case
  2347.       case .not. "DOS" $ UPPER(OS())  && gotta be DOS, not UNIX
  2348.          RETURN "Incompatible operating system"
  2349.       case pcount() # 0 .and. type("cDRIVE") # "C"
  2350.          RETURN "Invalid Parameter"
  2351.       case type("cDrive") = "C" .and. .not. isalpha(left(m->cDrive,1))
  2352.          RETURN "Invalid Parameter"
  2353.    endcase
  2354.  
  2355.    *-- deal with file already being there
  2356.    if file("DIRECT.XXX")
  2357.       erase direct.xxx
  2358.    endif
  2359.  
  2360.    *-- save screen and then clear whatever's on it
  2361.    save screen to sDirList
  2362.    clear
  2363.  
  2364.    *-- get the "message" color from the attributes ....
  2365.    cMsgColor = substr(set("ATTRIBUTE"),at(chr(38),set("ATTRIBUTE"))+3)
  2366.    cMsgColor = substr(m->cMsgColor,at(",",m->cMsgColor)+1)
  2367.    cMsgColor = substr(m->cMsgColor,at(",",m->cMsgColor)+1)
  2368.    cMsgColor = left(m->cMsgColor,at(",",m->cMsgColor)-1)
  2369.  
  2370.    *-- display message (slightly modified by KJM)
  2371.    @ 9,22 fill to 13,60 color n+/n  && shadow
  2372.    @ 8,20 fill to 12,58 color &cMsgColor.
  2373.    @ 8,20 to 12,58 double color &cMsgColor.
  2374.    @10,22 say "The directory tree is being created" color &cMsgColor.
  2375.  
  2376.    *-- execute DOS RUN command, putting output into a text file
  2377.    if type("CDRIVE") = "L"
  2378.       * tree must be run in DOS directory or in DOS path
  2379.       nRun = run(.f.,"TREE \ > direct.XXX",.t.)
  2380.    else
  2381.       cDrive = left(m->cDrive,1)+":\"
  2382.       nRun = run(.f.,"TREE &cDrive. > direct.xxx",.t.)
  2383.    endif
  2384.  
  2385.    *-- error has occured of some sort -- return error number OR -1
  2386.    if m->nRun # 0 .or. .not. file("DIRECT.XXX")
  2387.       RETURN iif(m->nRun # 0,m->nRun, -1)
  2388.    endif
  2389.  
  2390.    *-- use low-level routines to go in and deal with the file ...
  2391.    nHandle = fopen("DIRECT.XXX","R")   && open text file
  2392.    cMove   = fGets(m->nHandle,":")
  2393.    if feof(m->nHandle)
  2394.       lClose = fClose(m->nHandle)
  2395.       erase direct.xxx
  2396.       restore screen from sDirList
  2397.       release screen sDirList
  2398.       RETURN - 1
  2399.    endif
  2400.    cMove = fSeek(m->nHandle,len(m->cMove)-1)
  2401.  
  2402.    *-- define the popup
  2403.    define popup pTree from 1,20
  2404.    nBar = 1
  2405.    do while .not. feof(m->nHandle)
  2406.       define bar nBar of pTree prompt space(2) ;
  2407.         + fGets(m->nHandle)+space(5)
  2408.       nBar = m->nBar + 1
  2409.    enddo
  2410.  
  2411.    *-- store path (bar) & location of ascii 195 (√) or 192 (¿) to array
  2412.    declare aTemp[m->nBar,2]    && temp array
  2413.    nBar = 1
  2414.    cMove = fSeek(m->nHandle,0,0)
  2415.    cMove = fGets(m->nHandle,":")
  2416.    cMove = fSeek(m->nHandle,len(m->cMove) - 1)
  2417.    do while .not. feof(m->nHandle)
  2418.       cBar = trim(fGets(m->nHandle))
  2419.       store cBar to aTemp[m->nBar,1]
  2420.       store iif(at(chr(195),m->cBar) # 0, at(chr(195),m->cBar),;
  2421.             at(chr(192),m->cBar)) to aTemp[m->nBar,2]
  2422.       nBar = m->nBar + 1
  2423.    enddo
  2424.  
  2425.    *-- hokay ...
  2426.    clear
  2427.    cUser = ""
  2428.    *-- when user selects something, execute routine WhatDir ...
  2429.    on selection popup pTree do whatdir with bar(),m->cUser
  2430.    activate popup pTree
  2431.    release popup pTree
  2432.    lClose = fClose(m->nHandle)
  2433.    erase direct.xxx
  2434.    restore screen from sDirList
  2435.    release screen sDirList
  2436.  
  2437. RETURN m->cUser
  2438. *-- EoF: DirList()
  2439.  
  2440. PROCEDURE WhatDir
  2441. *----------------------------------------------------------------------
  2442. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2443. *-- Date........: 02/01/1993
  2444. *-- Notes.......: Part of DIRLIST() above -- this is used to extract
  2445. *--               out of the prompt from a popup, the directory a user
  2446. *--               selected ... This routine should not be used on its
  2447. *--               own ... it assumes too much (like array aTemp[] being
  2448. *--               in existence, and such)
  2449. *-- Written for.: dBASE IV, 1.5
  2450. *-- Rev. History: 02/01/1993 -- Original Release
  2451. *-- Calls.......: GRAt()               Function in FILES.PRG
  2452. *-- Called by...: DirList()
  2453. *-- Usage.......: Do WhatDir with <nBar>,<cDir>
  2454. *-- Example.....: Do WhatDir with bar(),cUser
  2455. *-- Returns.....: Directory
  2456. *-- Parameters..: nBar  = bar number of popup
  2457. *--               cDir  = prompt from popup to extract data ...
  2458. *----------------------------------------------------------------------
  2459.  
  2460.    parameters nBar, cDir
  2461.  
  2462.    if m->nBar # 1
  2463.       cDir = substr(aTemp[m->nBar,1],GRAt(aTemp[m->nBar,1])+1)
  2464.       nLevel = aTemp[m->nBar,2]
  2465.       nBar = m->nBar - 1
  2466.       do while m->nBar # 1
  2467.          if aTemp[m->nBar,2] < m->nLevel
  2468.             cDir = substr(aTemp[m->nBar,1],GRAt(aTemp[m->nBar,1])+1);
  2469.                      +"\"+m->cDir
  2470.             nLevel = aTemp[m->nBar,2]
  2471.          endif
  2472.          nBar = m->nBar - 1
  2473.       enddo
  2474.       cDir = aTemp[1,1] + m->cDir
  2475.    else
  2476.       cDir = aTemp[1,1]
  2477.    endif
  2478.    deactivate popup
  2479.  
  2480. RETURN
  2481. *-- EoP: WhatDir
  2482.  
  2483. FUNCTION GRAt
  2484. *----------------------------------------------------------------------
  2485. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2486. *-- Date........: 02/01/1993
  2487. *-- Notes.......: Graphic Reverse At -- Returns position of the first
  2488. *--               graphic character from the right of the string.
  2489. *--               Originally printed in TechNotes, February, 1993
  2490. *-- Written for.: dBASE IV, 1.5
  2491. *-- Rev. History: 02/01/1993 -- Original Release
  2492. *-- Calls.......: None
  2493. *-- Called by...: WhatDir
  2494. *-- Usage.......: GRAt(<cString>)
  2495. *-- Example.....: n = GRAt(cBar)
  2496. *-- Returns.....: Numeric
  2497. *-- Parameters..: cString = string to search
  2498. *----------------------------------------------------------------------
  2499.  
  2500.    parameters cString
  2501.  
  2502.    nLen = len(m->cString)
  2503.    lFound = .f.
  2504.  
  2505.    do while m->nLen # 0
  2506.       cChar = substr(m->cString,m->nLen,1)
  2507.       if asc(m->cChar) > 175 .and. asc(m->cChar) < 224
  2508.          lFound = .t.
  2509.          exit
  2510.       endif
  2511.       nLen = m->nLen - 1
  2512.    enddo
  2513.  
  2514. RETURN iif(m->lFound,m->nLen,-1)
  2515. *-- EoF: GRAt()
  2516.  
  2517. FUNCTION FF
  2518. *----------------------------------------------------------------------
  2519. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2520. *-- Date........: 02/01/1993
  2521. *-- Notes.......: This routine will search a disk and find all
  2522. *--               occurences of a specified file or files. It will then
  2523. *--               allow you to select said file.
  2524. *--               Originally printed in TechNotes, February, 1993
  2525. *--               *********************************
  2526. *--               **** USES DOS ATTRIB COMMAND ****
  2527. *--               *********************************
  2528. *-- Written for.: dBASE IV, 1.5
  2529. *-- Rev. History: 02/01/1993 -- Original Release
  2530. *-- Calls.......: None
  2531. *-- Called by...: Any
  2532. *-- Usage.......: FF(<cFile>[,<cPath>])
  2533. *-- Example.....: ?ff("*.dbf","c:\temp")
  2534. *-- Returns.....: Selected File
  2535. *-- Parameters..: cFile  = Filename, or wildcard specification, allows
  2536. *--                        use of standard ? and * wildcards in the way
  2537. *--                        DOS has always used them.
  2538. *--               cPath  = Optional -- specified drive and directory.
  2539. *--                        If not used, this UDF will start the search
  2540. *--                        at the root of the default drive.
  2541. *----------------------------------------------------------------------
  2542.  
  2543.    parameters cFile,cPath
  2544.  
  2545.    cCurDir = set("DIRECTORY")
  2546.  
  2547.    *-- deal with error messages
  2548.    do case
  2549.       case type("CFILE") # "C"
  2550.          RETURN "Invalid Parameter"
  2551.       case pcount() > 1 .and. type("CFILE") # "C"
  2552.          RETURN "Invalid Parameter"
  2553.       case pcount() > 1 .and. type("CFILE") = "C"
  2554.          lError = .f.
  2555.          on error lError = .t.
  2556.          set directory to &cPath.
  2557.          on error
  2558.          if m->lError
  2559.             RETURN "Invalid Drive\Directory"
  2560.          endif
  2561.    endcase
  2562.  
  2563.    if file("TEMP.XXX")
  2564.       erase temp.xxx
  2565.    endif
  2566.  
  2567.    *-- save screen so we can restore it, and clear ...
  2568.    save screen to sFF
  2569.    clear
  2570.  
  2571.    *-- get the "message" color from the attributes ....
  2572.    cMsgColor = substr(set("ATTRIBUTE"),at(chr(38),set("ATTRIBUTE"))+3)
  2573.    cMsgColor = substr(m->cMsgColor,at(",",m->cMsgColor)+1)
  2574.    cMsgColor = substr(m->cMsgColor,at(",",m->cMsgColor)+1)
  2575.    cMsgColor = left(m->cMsgColor,at(",",m->cMsgColor)-1)
  2576.  
  2577.    *-- display message
  2578.    @ 9,22 fill to 13,60 color n+/n  && shadow
  2579.    @ 8,20 fill to 12,58 color &cMsgColor.
  2580.    @ 8,20 to 12,58 double color &cMsgColor.
  2581.    @10,22 say "The directories are being searched" color &cMsgColor.
  2582.  
  2583.    *-- if no path was given, run the DOS Attrib command on whole drive
  2584.    if type("CPATH") = "L"
  2585.       nDosF = run(.f.,"ATTRIB \&cFile. /s > temp.xxx | sort",.t.)
  2586.    else  && run it on the path that was given ...
  2587.       nDosF = run(.f.,"ATTRIB  &cFile. /s > temp.xxx | sort",.t.)
  2588.    endif
  2589.  
  2590.    *-- if there was an error ...
  2591.    if m->nDosF # 0 .or. .not. file("TEMP.XXX")
  2592.       set directory to &cCurDir.
  2593.       restore screen from sFF
  2594.       release screen sFF
  2595.       RETURN iif(m->nDosF # 0,m->nDosF,-1)
  2596.    endif
  2597.  
  2598.    *-- use LOWLEVEL routines to process the output of ATTRIB command
  2599.    nHandle = fopen("TEMP.XXX","R")
  2600.    cMove   = fgets(m->nHandle,":")
  2601.    if feof(m->nHandle)
  2602.       lClose = fClose(m->nHandle)
  2603.       erase temp.xxx
  2604.       restore screen from sFF
  2605.       release screen sFF
  2606.       RETURN "File not found"
  2607.    endif
  2608.  
  2609.    *-- ok. Now we create the popup ...
  2610.    cMove = fseek(m->nHandle,0,0)
  2611.    nBar = 1
  2612.    define popup pFile from 1,1
  2613.    do while .not. feof(m->nHandle)
  2614.       cBar = trim(fgets(m->nHandle))
  2615.       cBar = space(2)+substr(m->cBar,at(":",m->cBar)-1)+space(5)
  2616.       define bar nBar of pFile prompt m->cBar
  2617.       nBar = m->nBar + 1
  2618.    enddo
  2619.  
  2620.    *-- what do we do with it?
  2621.    clear
  2622.    on selection popup pFile deactivate popup
  2623.    activate popup pFile
  2624.    cSelect = iif(.not. isblank(prompt()), ltrim(rtrim(prompt())),"")
  2625.  
  2626.    *-- cleanup
  2627.    release popup pFile
  2628.    lClose = fclose(m->nHandle)
  2629.    erase temp.xxx
  2630.    set directory to &cCurDir.
  2631.    restore screen from sFF
  2632.    release screen sFF
  2633.  
  2634. RETURN m->cSelect
  2635. *-- EoF: FF()
  2636.  
  2637. FUNCTION MakeStr
  2638. *----------------------------------------------------------------------
  2639. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223) 
  2640. *--               (from code published in DBA)
  2641. *-- Date........: 11/25/1992
  2642. *-- Notes.......: Creates an empty structure extended database
  2643. *-- Written for.: dBASE IV 1.5+
  2644. *-- Rev. History: 11/25/1992 - Rev A uses structure of currently open 
  2645. *--                 database, if present
  2646. *-- Calls.......: None
  2647. *-- Called by...: Any
  2648. *-- Usage.......: MakeStr(<cFileName.Ext>)
  2649. *-- Example.....: lDummy = MakeStr("G_HELP.STR")
  2650. *-- Returns.....: .F. if no file was created, .T. if one was
  2651. *-- Parameters..: cFileName = Name of file to create
  2652. *----------------------------------------------------------------------
  2653.  
  2654.    parameters cFileName
  2655.    private ALL
  2656.  
  2657.    if isblank(m->cFileName)
  2658.       return .F.
  2659.    endif
  2660.  
  2661.    if .not. isblank(alias())
  2662.       copy structure extended to &cFileName.
  2663.    else
  2664.       * code from DataBased Advisor to create an empty DBF
  2665.       nLoopCount = 1  && Loop counter
  2666.       nDim       = 5  && Number of rows in the DBF structure array
  2667.  
  2668.       * Declare array with the structure of the "structure extended"
  2669.       * DBF file
  2670.       DECLARE aDbfStru[m->nDim,5]
  2671.  
  2672.       aDbfStru[1,1] = "FIELD_NAME"   && field name
  2673.       aDbfStru[1,2] = "C"            && field type
  2674.       aDbfStru[1,3] = 10             && field length
  2675.       aDbfStru[1,4] = 0              && number of decimal places
  2676.       aDbfStru[1,5] = "N"            && MDX index tag
  2677.  
  2678.       aDbfStru[2,1] = "FIELD_TYPE"
  2679.       aDbfStru[2,2] = "C"
  2680.       aDbfStru[2,3] =  1
  2681.       aDbfStru[2,4] =  0
  2682.       aDbfStru[2,5] = "N"
  2683.  
  2684.       aDbfStru[3,1] = "FIELD_LEN"
  2685.       aDbfStru[3,2] = "N"
  2686.       aDbfStru[3,3] = 3
  2687.       aDbfStru[3,4] = 0
  2688.       aDbfStru[3,5] = "N"
  2689.  
  2690.       aDbfStru[4,1] = "FIELD_DEC"
  2691.       aDbfStru[4,2] = "N"
  2692.       aDbfStru[4,3] = 3
  2693.       aDbfStru[4,4] = 0
  2694.       aDbfStru[4,5] = "N"
  2695.  
  2696.       aDbfStru[5,1] = "FIELD_IDX"
  2697.       aDbfStru[5,2] = "C"
  2698.       aDbfStru[5,3] = 1
  2699.       aDbfStru[5,4] = 0
  2700.       aDbfStru[5,5] = "N"
  2701.  
  2702.       * Redirect printer output to a file
  2703.       SET PRINTER TO FILE (m->cFileName)
  2704.       SET PRINT ON
  2705.  
  2706.       * Write DBF file header
  2707.       * First byte (byte 0)- DBF file indicator
  2708.       ??? '{3}'
  2709.  
  2710.       * Creation date - bytes 1-3
  2711.       ??? CHR(VAL(RIGHT(STR(YEAR(DATE())),2))) + ;
  2712.           CHR(MONTH(DATE())) + CHR(DAY(DATE()))
  2713.  
  2714.       * Number of records in the file (zero) - bytes 1-3
  2715.       ??? REPLICATE('{0}',4)
  2716.  
  2717.       * Number of bytes in the header - bytes 8-9
  2718.       ??? '{193}{0}'
  2719.  
  2720.       * Number of bytes in the record (19) - bytes 10-11
  2721.       ??? '{19}{0}'
  2722.  
  2723.       * Bytes 12-31 of the header - not used here
  2724.       * Some appear to have constant value
  2725.       ??? REPLICATE('{0}',18)
  2726.       ??? '{57}{1}'
  2727.  
  2728.       * Field descriptor bytes - looping through the array
  2729.       * nDim times (5 in this case)
  2730.       * Field descriptors are each 32 bytes long
  2731.       DO WHILE m->nLoopCount <= m->nDim
  2732.  
  2733.          * Field name - bytes 0-10
  2734.          ??? aDbfStru[m->nLoopCount,1] +;
  2735.              REPLICATE('{0}', 11-LEN(TRIM(aDbfStru[m->nLoopCount,1])))
  2736.  
  2737.          * Field type - byte 11
  2738.          ??? aDbfStru[m->nLoopCount,2]
  2739.  
  2740.          * Bytes 12-15 - not used here
  2741.          ??? REPLICATE('{0}',2)
  2742.          ??? '{238}{85}'
  2743.  
  2744.          * Field length - byte 16
  2745.          ??? CHR(aDbfStru[m->nLoopCount,3])
  2746.  
  2747.          * Field decimal count - byte 17
  2748.          ??? IIF(aDbfStru[m->nLoopCount,4] > 0, ;
  2749.              CHR(aDbfStru[m->nLoopCount,4]), '{0}')
  2750.  
  2751.          * Bytes 18-19 - reserved
  2752.          ??? REPLICATE('{0}',2)
  2753.  
  2754.          * Byte 20 - work area ID.  Let's use 1 for simplicity
  2755.          ??? '{1}'
  2756.  
  2757.          * Bytes 21-31 - MDX index tag flag and reserved bytes
  2758.          ??? IIF(aDbfStru[m->nLoopCount,5] $ 'YyTt', '{1}', '{0}')
  2759.          ??? REPLICATE('{0}',10)
  2760.  
  2761.          * Increment loop counter
  2762.          nLoopCount = m->nLoopCount + 1
  2763.       ENDDO
  2764.  
  2765.       * DBF file header terminator and EOF character - byte n+1
  2766.       ??? '{13}{26}'
  2767.  
  2768.       SET PRINTER TO
  2769.       SET PRINT OFF
  2770.    endif
  2771.    select (select())
  2772.    use &cFileName. exclusive
  2773.    zap
  2774.  
  2775. RETURN .T.
  2776. *-- EoF: MakeStr()
  2777.  
  2778. FUNCTION RecChged
  2779. *----------------------------------------------------------------------
  2780. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  2781. *-- Date........: 11/25/1992
  2782. *-- Notes.......: Test field values against memory variables to see if
  2783. *--               an on-screen display has changed from the disk-record
  2784. *--               CHANGE() requires the existence of field _DBASELOCK
  2785. *--               whereas RecChged does not.
  2786. *-- Written for.: dBASE IV 1.1+
  2787. *-- Rev. History: 11/25/1992  for dBase IV 1.5
  2788. *--               10/08/1992  don't test memo-fields
  2789. *--               06/09/1992  dropped PCount() for 4.11 use
  2790. *--               06/04/1992  skips _DBASELOCK field
  2791. *--               08/02/1993  minor tuning
  2792. *-- Calls.......: FldCount() (1.1)
  2793. *--               ExEqual()         Function in STRINGS.PRG
  2794. *-- Called by...: Any
  2795. *-- Usage.......: RecChged(<cTable_Name>)
  2796. *-- Example.....: if RecChged("mpl") .and. Confirm("Save?",.Y.)
  2797. *-- Returns.....: .T. = record is changed  .F. = record is not changed
  2798. *-- Parameters..: cTable_Name = (OPTIONAL) alias of table to test
  2799. *----------------------------------------------------------------------
  2800.  
  2801.    parameters ctable_name
  2802.    if empty(m->ctable_name)
  2803.       ctable_name = alias()
  2804.    endif
  2805.    n = 1
  2806.    do while m->n <= fldcount(m->ctable_name)
  2807.      test_field = field(m->n,m->ctable_name)
  2808.      test_disk = "&ctable_name.->&test_field."
  2809.      * Thu  06-04-1992  don't test _DBASELOCK field
  2810.      * Thu  10-08-1992  check for existence of the field in the table
  2811.      *                  skip check for memo fields
  2812.      if .not. upper(test_field) = "_DBASELOCK" .and. ;
  2813.         .not. type("&test_disk.") $ "MU" .and. ;
  2814.         .not. type("m->&test_field.") ="U" .and. ;
  2815.         .not. ExEqual(m->&test_field.,&test_disk.)
  2816.            return .T.
  2817.       endif
  2818.       n = m->n + 1
  2819.    enddo
  2820.  
  2821. RETURN .F.
  2822. *-- EoF: RecChged()
  2823.  
  2824. FUNCTION CopyFile
  2825. *----------------------------------------------------------------------
  2826. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2827. *-- Date........: 04/26/1993
  2828. *-- Notes.......: Copies a database plus its production index (if it
  2829. *--               has one), and the DBT file if it exists as well.
  2830. *--               Use this instead of the COPY TO... WITH PRODUCTION
  2831. *--               command. Because it uses the COPY FILE command (a
  2832. *--               file-to-file copy) instead of the COPY TO command (a
  2833. *--               record-by-record copy), this is much faster.
  2834. *--               The DBF must be closed when you use this UDF.
  2835. *-- Written for.: dBASE IV, 1.5
  2836. *-- Rev. History: 04/26/1993  -- Original
  2837. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2838. *--               DbfName()            Function in FILES.PRG
  2839. *-- Called by...: Any
  2840. *-- Usage.......: CopyFile("<cOldFile>","<cNewFile>")
  2841. *-- Example.....: CopyFile("FRED","MARY")
  2842. *-- Returns.....: nError - 0 if copy operation worked okay.
  2843. *--                        1 if file to be copied didn't exist.
  2844. *-- Parameters..: cOldFile - DBF file to be copied
  2845. *--               cNewFile - Name for copy of DBF
  2846. *----------------------------------------------------------------------
  2847.  
  2848.    parameters cOldFile,cNewFile
  2849.    private cOldFile, cNewFile, lOpen, nRec, cTag, cAlias, nError
  2850.  
  2851.    nError = 0
  2852.  
  2853.    *-- Check if database actually exists
  2854.    if file(m->cOldFile + ".DBF")
  2855.  
  2856.       *-- Copy the file
  2857.       copy file m->cOldFile + ".DBF" to m->cNewFile + ".DBF"
  2858.  
  2859.       *-- Copy its MDX file
  2860.       if file(m->cOldFile + ".MDX")
  2861.  
  2862.          copy file m->cOldFile + ".MDX" to m->cNewFile + ".MDX"
  2863.          *-- Update the hard-coded database reference in the MDX header
  2864.          xJunk = MdxPoint(m->cNewFile)
  2865.  
  2866.       endif
  2867.  
  2868.       *-- Copy its memo file
  2869.       if file(m->cOldFile + ".DBT")
  2870.  
  2871.          copy file m->cOldFile + ".DBT" to m->cNewFile + ".DBT"
  2872.  
  2873.       endif
  2874.  
  2875.    else
  2876.       nError = 1
  2877.  
  2878.    endif
  2879.  
  2880. RETURN (m->nError)
  2881. *-- EoF: CopyFile()
  2882.  
  2883. FUNCTION CopyFil1
  2884. *----------------------------------------------------------------------
  2885. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2886. *-- Date........: 04/26/1993
  2887. *-- Notes.......: Copies a database plus its production index (if it
  2888. *--               has one), and the DBT file if it exists as well.
  2889. *--               Based on CopyFile().
  2890. *--               With this version, it doesn't matter whether the
  2891. *--               file you're copying is open or closed. If it's open,
  2892. *--
  2893. *--               * current index order
  2894. *--               * alias
  2895. *--               * record pointer
  2896. *--
  2897. *--               will all be retained.
  2898. *--               You must SET DBTRAP OFF before calling this routine
  2899. *--               from a program or the dot prompt.
  2900. *-- Written for.: dBASE IV, 1.5
  2901. *-- Rev. History: 04/26/1993  -- Original
  2902. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2903. *--               DbfName()            Function in FILES.PRG
  2904. *-- Called by...: Any
  2905. *-- Usage.......: CopyFile("<cOldFile>","<cNewFile>")
  2906. *-- Example.....: CopyFile("FRED","MARY")
  2907. *-- Returns.....: nError - 0 if copy operation worked okay.
  2908. *--                        1 if file to be copied didn't exist.
  2909. *-- Parameters..: cOldFile - DBF file to be copied
  2910. *--               cNewFile - Name for copy of DBF
  2911. *----------------------------------------------------------------------
  2912.  
  2913.    parameters cOldFile,cNewFile
  2914.    private cOldFile, cNewFile, lOpen, nRec, cTag, cAlias, nError
  2915.  
  2916.    lOpen  = .F.
  2917.    nError = 0
  2918.  
  2919.    *-- Check whether database exists
  2920.    if file(m->cOldFile + ".DBF")
  2921.  
  2922.       *-- If database is currently open, save info about it
  2923.       if DbfName() = upper(m->cOldFile)
  2924.          nRec   = recno()
  2925.          cTag   = tag()
  2926.          cAlias = alias()
  2927.          lOpen  = .T.
  2928.          use
  2929.       endif
  2930.  
  2931.       *-- Copy the database
  2932.       copy file m->cOldFile + ".DBF" to m->cNewFile + ".DBF"
  2933.  
  2934.       *-- Copy its MDX
  2935.       if file(m->cOldFile + ".MDX")
  2936.  
  2937.          copy file m->cOldFile + ".MDX" to m->cNewFile + ".MDX"
  2938.          *-- Update the hard-coded database reference in the MDX header
  2939.          xJunk = MdxPoint(m->cNewFile)
  2940.  
  2941.       endif
  2942.  
  2943.       *-- Copy its memo file
  2944.       if file(m->cOldFile + ".DBT")
  2945.  
  2946.          copy file m->cOldFile + ".DBT" to m->cNewFile + ".DBT"
  2947.  
  2948.       endif
  2949.  
  2950.       *-- If file was originally open, reopen it and restore its state
  2951.       if m->lOpen
  2952.          use (m->cOldFile) ALIAS &cAlias.
  2953.          if "" <> m->cTag
  2954.             set order to (m->cTag)
  2955.          endif
  2956.          go m->nRec
  2957.       endif
  2958.  
  2959.    else
  2960.       m->nError = 1
  2961.  
  2962.    endif
  2963.  
  2964. RETURN (m->nError)
  2965. *-- EoF: CopyFil1()
  2966.  
  2967. FUNCTION RenFile
  2968. *----------------------------------------------------------------------
  2969. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2970. *-- Date........: 04/26/1993
  2971. *-- Notes.......: Renames a .DBF file and its production index and
  2972. *--               memo files (if they exist) and correctly updates
  2973. *--               the .MDX header.
  2974. *--               The DBF must be closed before using this UDF.
  2975. *-- Written for.: dBASE IV, 1.5
  2976. *-- Rev. History: 04/26/1993  -- Original
  2977. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2978. *--               DbfName()            Function in FILES.PRG
  2979. *-- Called by...: Any
  2980. *-- Usage.......: RenFile("<cOldFile>","<cNewFile>")
  2981. *-- Example.....: RenFile("FRED","MARY")
  2982. *-- Returns.....: nError   - 0 if renaming operation went okay.
  2983. *--                          1 if file to be renamed didn't exist.
  2984. *-- Parameters..: cOldFile - Current database name
  2985. *--               cNewFile - New name for database
  2986. *----------------------------------------------------------------------
  2987.  
  2988.    parameters cOldFile,cNewFile
  2989.    private cOldFile, cNewFile, lOpen, nError, nRec, cTag, cAlias, xJunk
  2990.  
  2991.    nError = 0
  2992.  
  2993.    *-- Check whether database exists
  2994.    if file(m->cOldFile + ".DBF")
  2995.  
  2996.       *--  Rename it
  2997.       rename m->cOldFile + ".DBF" to m->cNewFile + ".DBF"
  2998.  
  2999.       *-- Rename its MDX
  3000.       if file(m->cOldFile + ".MDX")
  3001.  
  3002.          rename m->cOldFile + ".MDX" to m->cNewFile + ".MDX"
  3003.          *-- Update the hard-coded database reference in the MDX header
  3004.          xJunk = MdxPoint(m->cNewFile)
  3005.  
  3006.       endif
  3007.  
  3008.       *-- Rename its memo file
  3009.       if file(m->cOldFile + ".DBT")
  3010.  
  3011.          rename m->cOldFile + ".DBT" to m->cNewFile + ".DBT"
  3012.  
  3013.       endif
  3014.  
  3015.    else
  3016.       nError = 1
  3017.  
  3018.    endif
  3019.  
  3020. RETURN (m->nError)
  3021. *-- EoF: RenFile()
  3022.  
  3023. FUNCTION RenFile1
  3024. *----------------------------------------------------------------------
  3025. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3026. *-- Date........: 04/26/1993
  3027. *-- Notes.......: Renames a .DBF file and its production index and memo
  3028. *--               files (if they exist) and correctly updates the .MDX
  3029. *--               header. This is a variant of RenFile().
  3030. *--               In this version, it doesn't matter whether the
  3031. *--               database is open or closed when you call the UDF. If
  3032. *--               it is open, the
  3033. *--
  3034. *--               * current index order
  3035. *--               * record pointer
  3036. *--
  3037. *--               will be restored after the renaming.
  3038. *--               You must SET DBTRAP OFF before calling this UDF.
  3039. *-- Written for.: dBASE IV, 1.5
  3040. *-- Rev. History: 04/26/1993  -- Original
  3041. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  3042. *--               DbfName()            Function in FILES.PRG
  3043. *-- Called by...: Any
  3044. *-- Usage.......: RenFile("<cOldFile>","<cNewFile>")
  3045. *-- Example.....: RenFile("FRED","MARY")
  3046. *-- Returns.....: nError   - 0 if renaming operation went okay.
  3047. *--                          1 if file to be renamed didn't exist.
  3048. *-- Parameters..: cOldFile - Current database name
  3049. *--               cNewFile - New name for database
  3050. *----------------------------------------------------------------------
  3051.  
  3052.    parameters cOldFile,cNewFile
  3053.    private cOldFile, cNewFile, lOpen, nError, nRec, cTag, xJunk
  3054.  
  3055.    lOpen  = .F.
  3056.    nError = 0
  3057.  
  3058.    *-- Check if database exists
  3059.    if file(m->cOldFile + ".DBF")
  3060.  
  3061.       *-- If database is currently open, save record pointer
  3062.       *-- and index order
  3063.       if DbfName() = upper(m->cOldFile)
  3064.          nRec   = recno()
  3065.          cTag   = tag()
  3066.          lOpen  = .T.
  3067.          use
  3068.       endif
  3069.  
  3070.       *-- Rename database
  3071.       rename m->cOldFile + ".DBF" to m->cNewFile + ".DBF"
  3072.  
  3073.       *-- Rename its MDX
  3074.       if file(m->cOldFile + ".MDX")
  3075.  
  3076.          rename m->cOldFile + ".MDX" to m->cNewFile + ".MDX"
  3077.          *-- Update the hard-coded database reference in the MDX header
  3078.          xJunk = MdxPoint(m->cNewFile)
  3079.  
  3080.       endif
  3081.  
  3082.       *-- Rename its memo file
  3083.       if file(m->cOldFile + ".DBT")
  3084.  
  3085.          rename m->cOldFile + ".DBT" to m->cNewFile + ".DBT"
  3086.  
  3087.       endif
  3088.  
  3089.       *-- If file was originally open, reopen it and restore its state
  3090.       if m->lOpen
  3091.          use (m->cNewFile)
  3092.          if "" <> m->cTag
  3093.             set order to (m->cTag)
  3094.          endif
  3095.          go m->nRec
  3096.       endif
  3097.  
  3098.    else
  3099.       nError = 1
  3100.  
  3101.    endif
  3102.  
  3103. RETURN (m->nError)
  3104. *-- EoF: RenFile1()
  3105.  
  3106. FUNCTION DelFile
  3107. *----------------------------------------------------------------------
  3108. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3109. *-- Date........: 04/26/1993
  3110. *-- Notes.......: Deletes a database, its production index and its memo
  3111. *--               file (if there is one) in one fell swoop.
  3112. *-- Written for.: dBASE IV, 1.5
  3113. *-- Rev. History: 04/26/1993  -- Original
  3114. *-- Calls.......: None
  3115. *-- Called by...: Any
  3116. *-- Usage.......: DelFile("<cDbfName>")
  3117. *-- Example.....: DelFile("FRED")
  3118. *-- Returns.....: nError    - 0 if file deletion went okay
  3119. *--                         - 1 if file to be deleted didn't exist.
  3120. *-- Parameters..: cDbfName  - Name of the database you wish to delete.
  3121. *----------------------------------------------------------------------
  3122.    parameters cDbfName
  3123.    private cDbfName, cMdxName, cDbtName, nError
  3124.  
  3125.    cMdxName  = m->cDbfName + ".MDX"
  3126.    cDbtName  = m->cDbfName + ".DBT"
  3127.    cDbfName  = m->cDbfName + ".DBF"
  3128.    nError    = 0
  3129.  
  3130.    *-- Check database exists
  3131.    if file(m->cDbfName)
  3132.  
  3133.       *-- Delete database
  3134.       delete file (m->cDbfName)
  3135.  
  3136.       *-- Delete its MDX
  3137.       if file(m->cMdxName)
  3138.          delete file (m->cMdxName)
  3139.       endif
  3140.  
  3141.       *-- Delete its memo file if any
  3142.       if file(m->cDbtName)
  3143.          delete file (m->cDbtName)
  3144.       endif
  3145.  
  3146.    else
  3147.  
  3148.       nError = 1
  3149.  
  3150.    endif
  3151.  
  3152. RETURN (m->nError)
  3153. *-- EoF: DelFile()
  3154.  
  3155. FUNCTION DelMdx
  3156. *----------------------------------------------------------------------
  3157. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3158. *-- Date........: 04/26/1993
  3159. *-- Notes.......: Deletes a production index file, correctly updating
  3160. *--               the production index byte in the DBF header, so you
  3161. *--               avoid the "Production index not found" message.
  3162. *-- Written for.: dBASE IV, 1.5
  3163. *-- Rev. History: 04/26/1993  -- Original
  3164. *-- Calls.......: None
  3165. *-- Called by...: Any
  3166. *-- Usage.......: DelMdx("<cMdx>")
  3167. *-- Example.....: DelMdx("fred")
  3168. *-- Returns.....: nError  =  0 if deletion is okay
  3169. *--                          1 if file doesn't exist
  3170. *-- Parameters..: cMdx = Production MDX file to delete
  3171. *----------------------------------------------------------------------
  3172.    parameters cMdx
  3173.    private cMdx, cMdxName, cDbfName, nHandle, nError, xJunk
  3174.  
  3175.  
  3176.    cMdxName = m->cMdx + ".MDX"
  3177.    cDbfName = m->cMdx + ".DBF"
  3178.    nError   = 0
  3179.  
  3180.    *-- Check if file exists
  3181.    if file(m->cMdxName)
  3182.  
  3183.       *-- Delete MDX file
  3184.       delete file (m->cMdxName)
  3185.  
  3186.       *-- Update MDX byte in DBF header, indicating there is no longer
  3187.       *-- an MDX for this database.
  3188.       nHandle = fopen((m->cDbfName),"rw")
  3189.       xJunk   = fseek(m->nHandle,28,0)
  3190.       xJunk   = fwrite(m->nHandle,chr(0))
  3191.       xJunk   = fclose(m->nHandle)
  3192.  
  3193.    else
  3194.  
  3195.       nError = 1
  3196.  
  3197.    endif
  3198.  
  3199. RETURN ("")
  3200. *-- EoF: DelMdx()
  3201.  
  3202. FUNCTION RestMdx
  3203. *----------------------------------------------------------------------
  3204. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3205. *-- Date........: 04/26/1993
  3206. *-- Notes.......: Restores a pointer to an (existing) production MDX
  3207. *--               file in the DBF header. Only really needed if you
  3208. *--               make a mess using the DelMdx() function.
  3209. *-- Written for.: dBASE IV, 1.5
  3210. *-- Rev. History: 04/26/1993  -- Original
  3211. *-- Calls.......: None
  3212. *-- Called by...: Any
  3213. *-- Usage.......: RestMdx("<cMdx>")
  3214. *-- Example.....: RestMdx("FRED")
  3215. *-- Returns.....: nError  - 0 if pointer restoration went okay
  3216. *--                         1 if the MDX didn't exist
  3217. *-- Parameters..: cMdx    - MDX/DBF file name.
  3218. *----------------------------------------------------------------------
  3219.  
  3220.    parameters cMdx
  3221.    private cMdxName, cDbfName, nHandle, xJunk, nError
  3222.  
  3223.    cMdxName = m->cMdx + ".MDX"
  3224.    cDbfName = m->cMdx + ".DBF"
  3225.  
  3226.    if file(m->cMdxName)
  3227.  
  3228.       *-- Update MDX byte in DBF header, indicating there is an
  3229.       *-- MDX for this database.
  3230.       nHandle = fopen((m->cDbfName),"rw")
  3231.       xJunk   = fseek(m->nHandle,28,0)
  3232.       xJunk   = fwrite(m->nHandle,chr(1))
  3233.       xJunk   = fclose(m->nHandle)
  3234.       nError  = 0
  3235.  
  3236.    else
  3237.  
  3238.       nError = 1
  3239.  
  3240.    endif
  3241.  
  3242. RETURN (m->nError)
  3243. *-- EoF: RestMdx()
  3244.  
  3245. FUNCTION MdxPoint
  3246. *----------------------------------------------------------------------
  3247. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3248. *-- Date........: 04/26/1993
  3249. *-- Notes.......: Changes the hard-coded DBF name in an MDX file header
  3250. *--               (either a production or non-production MDX).
  3251. *-- Written for.: dBASE IV, 1.5
  3252. *-- Rev. History: 04/26/1993  -- Original
  3253. *-- Calls.......: None
  3254. *-- Called by...: Any (Specifically CopyFile() and RenFile())
  3255. *-- Usage.......: MdxPoint("<cDbfName>", "<cMdx>")
  3256. *-- Example.....: MdxPoint("FRED")
  3257. *--               MdxPoint("FRED","FULLNAME")
  3258. *-- Returns.....: None
  3259. *-- Parameters..: cDbfName - The name of the DBF to be hard-coded into
  3260. *--                          the MDX header.
  3261. *--               cMdx     - The name of the MDX file, if it's a
  3262. *--                          non-production MDX (omit this parameter
  3263. *--                          completely if it's a production MDX).
  3264. *----------------------------------------------------------------------
  3265.  
  3266.    parameters cDbfName, cMdx
  3267.    private nPadl, cDbfName, nHandle, xJunk, n
  3268.  
  3269.    *-- Find out how long the DBF filename is and set padding length
  3270.    nPadl    = 8 - len(m->cDbfName)
  3271.    cDbfName = upper(m->cDbfName)
  3272.  
  3273.    *-- Check how many parameters have been passed: 1 means its a
  3274.    *-- production index, 2 is a non-production index
  3275.    if pcount() < 2
  3276.  
  3277.       nHandle = fopen((m->cDbfName)+".MDX","rw")
  3278.  
  3279.    else
  3280.  
  3281.       nHandle = fopen((m->cMdx)+".MDX","rw")
  3282.  
  3283.    endif
  3284.  
  3285.    *-- Position file pointer to Byte 4, which is start of hard-coded
  3286.    *-- DBF name in MDX header
  3287.    xJunk   = fseek(m->nHandle,4,0)
  3288.    *-- Write the new DBF filename into the header
  3289.    xJunk   = fwrite(m->nHandle,(m->cDbfName))
  3290.  
  3291.    n = 0
  3292.  
  3293.    do while m->n < m->nPadl
  3294.  
  3295.       *-- Pad filename out to 8 characters in header, using nulls
  3296.       xJunk  = fwrite(m->nHandle,chr(0))
  3297.       n      = m->n + 1
  3298.  
  3299.    enddo
  3300.  
  3301.    xJunk = fclose(m->nHandle)
  3302.  
  3303. RETURN ("")
  3304. *-- EoF: MdxPoint()
  3305.  
  3306. FUNCTION DbfName
  3307. *----------------------------------------------------------------------
  3308. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3309. *-- Date........: 04/26/1993
  3310. *-- Notes.......: Strips the 8-character DBF filename out of the full
  3311. *--               pathname returned by the dbf() function. Works on the
  3312. *--               database in USE in the current workarea.
  3313. *-- Written for.: dBASE IV, 1.5
  3314. *-- Rev. History: 04/26/1993  -- Original
  3315. *-- Calls.......: None
  3316. *-- Called by...: Any (Specifically CopyFile() and RenFile()).
  3317. *-- Usage.......: DbfName()
  3318. *-- Example.....: DbfName()
  3319. *-- Returns.....: cName   =  8-character filename of DBF.
  3320. *-- Parameters..: None
  3321. *----------------------------------------------------------------------
  3322.    private cFullPath, cName
  3323.  
  3324.    cFullPath = set("FULLPATH")
  3325.    set fullpath off
  3326.  
  3327.    *-- Check if a database is open in the current workarea
  3328.    if "" <> dbf()
  3329.  
  3330.       *-- Strip the filename out of the full pathname
  3331.       cName = ( substr( dbf(), 3, at( ".", dbf() ) - 3 ) )
  3332.  
  3333.    else
  3334.  
  3335.       cName = ""
  3336.  
  3337.    endif
  3338.  
  3339.    set fullpath &cFullPath.
  3340.  
  3341. RETURN (m->cName)
  3342. *-- EoF: DbfName()
  3343.  
  3344. FUNCTION MdxGauge
  3345. *----------------------------------------------------------------------
  3346. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3347. *-- Date........: 04/26/1993
  3348. *-- Notes.......: Indexes a database, showing a 'fuel-gauge' style
  3349. *--               progress indicator during the process.
  3350. *--               You must SET DBTRAP OFF in the calling routine or at
  3351. *--               the dot prompt.
  3352. *--               This routine slows down indexing, but allows the user
  3353. *--               to know what's going on.
  3354. *-- Written for.: dBASE IV, 1.5
  3355. *-- Rev. History: 04/26/1993  -- Original
  3356. *-- Calls.......: Gauge(), DelGauge()
  3357. *-- Called by...: Any
  3358. *-- Usage.......: MdxGauge("<cDataFile>","<cIndexExp>","<cMTag>",;
  3359. *--                        "<cMdxName>","<cClr>",<nURow>,<nLCol>)
  3360. *-- Example.....: MdxGauge("FRED","upper(LNAME)+upper(FNAME)",;
  3361. *--                         "FULLNAME","",0,0)
  3362. *--
  3363. *--               This example indexes FRED.DBF on the uppercase last
  3364. *--               and firstnames, to the production MDX with a tagname
  3365. *--               of FULLNAME. It also uses your current default color
  3366. *--               scheme, and positions the fuel gauge at 0,0.
  3367. *--
  3368. *--               MdxGauge("FRED","substr(LNAME,5)","SHORTNAME",;
  3369. *--                        "OTHERS","r+/b,r+/b,b+/w";10,15)
  3370. *--
  3371. *--               This example indexes FRED.DBF on the first five
  3372. *--               characters of the lastname to a non-production MDX
  3373. *--               called OTHERS, using the tagname SHORTNAME. It sets
  3374. *--               the colors of the fuel- gauge and the fuel-gauge
  3375. *--               frame, and positions the gauge starting at 10,15.
  3376. *-- Returns.....: nError     =  0 if MDX header was updated correctly
  3377. *--                          =  1 if MDX header couldn't be updated
  3378. *-- Parameters..: cDataFile  =  DBF to be indexed
  3379. *--               cMdxExpr   =  Indexing expression
  3380. *--               cMdxTag    =  Index TAG name
  3381. *--               cMdxName   =  MDX name - only needed if using a
  3382. *--                             non-production MDX.
  3383. *--               cClr       =  Colors for fuel gauge. You can include
  3384. *--                             standard, enhanced and frame colors in
  3385. *--                             the string. If you don't include a
  3386. *--                             color string, the UDF will use the
  3387. *--                             current colors.
  3388. *--               nURow      =  Starting row for fuel gauge on screen.
  3389. *--                             Must be less than 20 - if not, the
  3390. *--                             program will make nURow = 19.
  3391. *--               nLCol      =  Starting column for fuel gauge.
  3392. *--                             Must be less than 26 - if not, the
  3393. *--                             program will make nLCol = 25.
  3394. *----------------------------------------------------------------------
  3395.  
  3396.    parameters cDbfName, cMdxExpr, cMdxTag, cMdxName, cClr, nURow, nLCol
  3397.    private nBarLen, cBarPad, cIndex, nError, nRecInt, nBarFull
  3398.  
  3399.    use (m->cDbfName)
  3400.  
  3401.    cStatus = set("STATUS")
  3402.    cSafety = set("SAFETY")
  3403.    cTalk   = set("TALK")
  3404.    set status off
  3405.    set safety off
  3406.    set talk off
  3407.  
  3408.    cMdxExpr  = upper(m->cMdxExpr)
  3409.    cMdxTag   = upper(m->cMdxTag)
  3410.  
  3411.    *-- If color parameter is blank, use default color scheme
  3412.    if cClr <> ""
  3413.  
  3414.       cClr = SET("ATTR")
  3415.  
  3416.    endif
  3417.  
  3418.  
  3419.    if m->nURow > 19
  3420.  
  3421.       nURow = 19
  3422.  
  3423.    endif
  3424.  
  3425.    if m->nLCol > 25
  3426.  
  3427.       nLCol = 25
  3428.  
  3429.    endif
  3430.  
  3431.    *-- Determine width of fuel-gauge
  3432.    if reccount() > 50
  3433.  
  3434.       nRecInt   = int(reccount()/50)
  3435.       nBarLen   = int( reccount() / m->nRecInt )
  3436.  
  3437.    else
  3438.  
  3439.       nBarLen   = reccount() + 1
  3440.  
  3441.    endif
  3442.  
  3443.    cBarPad = space(round((m->nBarLen-16)/3,0))
  3444.  
  3445.    clear
  3446.  
  3447.    *-- Display fuel-gauge window and empty gauge
  3448.    define window wGauge from m->nURow, m->nLCol;
  3449.            to m->nURow+5,m->nBarLen+m->nLCol+2 color &cClr.
  3450.    activate window wGauge
  3451.  
  3452.    @ 0,0 say "Indexing " + Dbf()
  3453.    @ 1,0 say "0%  " + m->cBarPad + "25% " + m->cBarPad + "75% " + ;
  3454.               m->cBarPad + "100%"
  3455.    @ 2,0 say replicate( chr(219), m->nBarlen )
  3456.    @ 2,0 say ""
  3457.  
  3458.    *-- Check if it's a production index or not, and then
  3459.    *-- use the appropriate index expression. The FOR condition
  3460.    *-- in the expression "fills up" the fuel gauge.
  3461.    if "" = m->cMdxName
  3462.  
  3463.       index on &cMdxExpr. tag &cMdxTag. for Gauge()
  3464.  
  3465.    else
  3466.       index on &cMdxExpr. tag &cMdxTag. of &cMdxName. for Gauge()
  3467.  
  3468.    endif
  3469.  
  3470.    *-- Clean up
  3471.    clear
  3472.    @ 2,0 say "Closing files..."
  3473.    nError  =  0
  3474.    cIndex  = mdx()
  3475.    use
  3476.  
  3477.    *-- Call UDF to delete reference to Gauge() UDF from MDX header
  3478.    nError = DelGauge(m->cIndex, m->cMdxTag)
  3479.  
  3480.    deactivate window wGauge
  3481.  
  3482.    set status &cStatus.
  3483.    set safety &cSafety.
  3484.    set talk &cTalk.
  3485.  
  3486. RETURN(m->nError)
  3487. *-- EoF: MdxGauge()
  3488.  
  3489. FUNCTION Gauge
  3490. *----------------------------------------------------------------------
  3491. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3492. *-- Date........: 04/26/1993
  3493. *-- Notes.......: Routine used by MdxGauge() to "fill up" the fuel-
  3494. *--               gauge on screen during indexing.
  3495. *--               It is called from an indexing "FOR" expression, and
  3496. *--               always returns .T. to include all records in index.
  3497. *-- Written for.: dBASE IV, 1.5
  3498. *-- Rev. History: 04/26/1993  -- Original
  3499. *-- Calls.......: None
  3500. *-- Called by...: MdxGauge()           Function in FILES.PRG
  3501. *-- Usage.......: Gauge()
  3502. *-- Example.....: Gauge()
  3503. *-- Returns.....: .T.
  3504. *-- Parameters..: None
  3505. *----------------------------------------------------------------------
  3506.  
  3507.         *-- Every time 2% of the file or so is indexed...
  3508.    if reccount() > 50
  3509.  
  3510.       if mod( recno(), m->nRecInt ) = 0
  3511.  
  3512.          *-- Display a solid bar character to "fill up" the gauge
  3513.          ?? chr(177)
  3514.  
  3515.       endif
  3516.  
  3517.    else
  3518.  
  3519.       ?? chr(177)
  3520.  
  3521.    endif
  3522.  
  3523. RETURN(.T.)
  3524. *-- EoF: Gauge()
  3525.  
  3526. FUNCTION DelGauge
  3527. *----------------------------------------------------------------------
  3528. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3529. *-- Date........: 04/26/1993
  3530. *-- Notes.......: Deletes all reference to the Gauge() UDF from within
  3531. *--               an MDX header file.
  3532. *-- Written for.: dBASE IV, 1.5
  3533. *-- Rev. History: 04/26/1993  -- Original
  3534. *-- Calls.......: FindTagExp()         Function in FILES.PRG
  3535. *-- Called by...: MdxGauge()
  3536. *-- Usage.......: DelGauge("<cMdx>","<cTag>")
  3537. *-- Example.....: DelGauge("FRED","upper(LASTNAME)+upper(FIRSTNAME)")
  3538. *-- Returns.....: nError  -  Error code.
  3539. *--                          0 if the UDF managed to delete the Gauge()
  3540. *--                          reference in the header.
  3541. *--                          1 if the UDF failed (it couldn't find the
  3542. *--                          Gauge() reference.
  3543. *-- Parameters..: cMdx  =  MDX file to search.
  3544. *--               cTag  =  TAG expression to search for.
  3545. *----------------------------------------------------------------------
  3546.    parameters cMdx, cTag
  3547.    private nHandle, nTagExp, nForFlag, nForExp, nError, n, xJunk
  3548.  
  3549.    *-- Open the MDX file
  3550.    nHandle = fopen(m->cMdx,'rw')
  3551.  
  3552.    *-- Find the information about the TAG in the MDX header
  3553.    nTagExp  = FindTagExp( m->nHandle, m->cTag )
  3554.    *-- Find the byte indicating whether a FOR clause was used
  3555.    *-- to create this particular TAG.
  3556.    nForFlag = m->nTagExp + 245
  3557.    *-- Find the start of the FOR expression in the TAG information
  3558.    nForExp  = m->nTagExp + 762
  3559.  
  3560.    *-- Place 00H in the byte indicating a FOR clause, to delete
  3561.    *-- reference to the FOR clause.
  3562.    xJunk    = fseek( m->nHandle, m->nForFlag, 0 )
  3563.    xJunk    = fwrite (m->nHandle, chr(0))
  3564.    *-- Positioning the pointer at the FOR clause in the TAG info.
  3565.    xJunk    = fseek( m->nHandle, m->nForExp, 0 )
  3566.  
  3567.    *-- Check that we've found our UDF reference in the FOR clause
  3568.    *-- and, if so, delete the reference to the UDF by writing a
  3569.    *-- series of nulls to the file over the word "GAUGE()".
  3570.    if upper(fread(m->nHandle,7)) = 'GAUGE()'
  3571.  
  3572.       nError  = 0
  3573.       xJunk  = fseek( m->nHandle, m->nForExp, 0)
  3574.       n      = 1
  3575.  
  3576.       do while m->n < 8
  3577.  
  3578.          xJunk  = fwrite(m->nHandle,chr(0))
  3579.          n      = m->n + 1
  3580.  
  3581.       enddo
  3582.  
  3583.    else
  3584.  
  3585.       nError = 1
  3586.  
  3587.    endif
  3588.  
  3589.    xJunk = Fclose(m->nHandle)
  3590.  
  3591. RETURN (m->nError)
  3592. *-- EoF: DelGauge()
  3593.  
  3594. FUNCTION FindTagExp
  3595. *----------------------------------------------------------------------
  3596. *-- Programmer..: Rose Vines (CIS: 100026,3153) (dBase version)
  3597. *-- Date........: 04/26/1993
  3598. *-- Notes.......: Finds the starting position of a specific index TAG
  3599. *--               expression within an MDX header.
  3600. *-- Written for.: dBASE IV, 1.5
  3601. *-- Rev. History: 04/26/1993  -- Original
  3602. *-- Calls.......: FLocate()            Function in FILES.PRG
  3603. *--               FReadI32()           Function in FILES.PRG
  3604. *-- Called by...: DelGauge()
  3605. *-- Usage.......: FindTagExp(<nHandle>,"<cMdxTag>")
  3606. *-- Example.....: FindTagExp( 5, "upper(LASTNAME)+upper(FIRSTNAME)" )
  3607. *-- Returns.....: nTagExp   -  Starting position of the TAG expression
  3608. *--                            within the MDX header file.
  3609. *-- Parameters..: nHandle  =  DOS file handle of an MDX file.
  3610. *--               cMdxTag  =  MDX TAG expression.
  3611. *----------------------------------------------------------------------
  3612.  
  3613.    parameters nHandle, cMdxTag
  3614.    private nJunk, nPos, nPoint, nTagExp
  3615.  
  3616.    *-- Shift pointer to byte 512 in the MDX file. At byte 512,
  3617.    *-- there's an array of TAG names.
  3618.    nJunk   = fseek( m->nHandle, 512, 0 )
  3619.    *-- From there, locate our particular TAG in the array
  3620.    nPos    = Flocate( m->nHandle, m->cMdxTag, .T. )
  3621.    *-- Back up and read the preceding 4 bytes, which are a pointer
  3622.    *-- to the file offset where the information about our TAG
  3623.    *-- is located in the MDX file.
  3624.    nJunk   = fseek( m->nHandle, m->nPos - 4 )
  3625.    *-- Convert the 4-byte pointer to decimal
  3626.    nPoint  = FreadI32( m->nHandle )
  3627.    *-- Return the starting position of the TAG info.
  3628.    nTagExp = fseek( m->nHandle, m->nPoint * 512 )
  3629.  
  3630. RETURN( m->nTagExp )
  3631. *-- EoF:  FindTagExp()
  3632.  
  3633. FUNCTION FLocate
  3634. *----------------------------------------------------------------------
  3635. *-- Programmer..: Rose Vines (CIS: 100026,3153) (dBase version)
  3636. *--               Matt Whelan (Clipper version - not included here)
  3637. *-- Date........: 04/26/1993
  3638. *-- Notes.......: Finds a string within a file, starting from current
  3639. *--               position of the file pointer (Operates using low-
  3640. *--               level file functions).
  3641. *--               Due to the 254-character limitation on dBase string
  3642. *--               variables, this is not particularly fast on large
  3643. *--               files as it must search through a 254-char buffer.
  3644. *--               The Clipper version, which uses a 65,535-character
  3645. *--               buffer, is much faster.
  3646. *-- Written for.: dBASE IV, 1.5
  3647. *-- Rev. History: 04/26/1993  -- Original
  3648. *-- Calls.......: FTell()              Function in FILES.PRG
  3649. *--               FLen()               Function in FILES.PRG
  3650. *-- Called by...: Any (Specifically FindTaxExp()).
  3651. *-- Usage.......: FLocate(<nHandle>,"<cSearch>",<lWantUpper>)
  3652. *-- Example.....: FLocate( 5, "Crabapple Cove", .T.)
  3653. *-- Returns.....: nFoundPos  -  Starting position of the string in file
  3654. *-- Parameters..: nHandle     =  DOS file handle
  3655. *--               cSearch     =  Search string
  3656. *--               lWantUpper  =  Whether you want the search string
  3657. *--                              first converted to uppercase.
  3658. *----------------------------------------------------------------------
  3659.  
  3660.    parameters nHandle, cSearch, lWantUpper
  3661.    private cBuffer, nCurPos, nStartPos, nBuffSize, nFlength
  3662.    private nBufPos, cTxtBuff, nBuffOffset, nFoundPos, cAddBuf
  3663.  
  3664.    nFoundPos  = -2
  3665.  
  3666.    *-- Convert search string to uppercase if required
  3667.    if pcount() = 2
  3668.  
  3669.       lWantUpper = .F.
  3670.  
  3671.    endif
  3672.  
  3673.    *-- If a valid file handle has been passed...
  3674.    if nHandle > 0
  3675.  
  3676.          *-- Store our current position in the file,
  3677.          *-- check the file length and then determine the
  3678.          *-- buffer size.
  3679.          nCurPos     = Ftell( m->nHandle )
  3680.          nStartPos   = m->nCurPos
  3681.          nFlength    = Flen( m->nHandle )
  3682.          nBuffSize   = min( 254, m->nFlength )
  3683.  
  3684.          *-- Now start reading characters into the buffer
  3685.          do while m->nCurPos < m->nFlength
  3686.  
  3687.             cBuffer = ""
  3688.  
  3689.             do while len(m->cBuffer) < m->nBuffSize
  3690.  
  3691.                cAddBuf = fread( m->nHandle, 1 )
  3692.  
  3693.                *-- If you read in a null, replace it in the buffer
  3694.                *-- by a space
  3695.                if chr(0) = m->cAddBuf
  3696.  
  3697.                   cAddBuf = " "
  3698.  
  3699.                endif
  3700.  
  3701.                cBuffer = m->cBuffer + m->cAddBuf
  3702.  
  3703.             enddo
  3704.  
  3705.             if lWantUpper
  3706.  
  3707.                cBuffer = upper(m->cBuffer)
  3708.  
  3709.             endif
  3710.  
  3711.             *-- See if the search string is in the buffer
  3712.             nBufPos = at( m->cSearch, m->cBuffer )
  3713.  
  3714.             *-- and if it is, store its position in the file
  3715.             if nBufPos > 0
  3716.  
  3717.                nFoundPos = m->nCurPos + m->nBufPos - 1
  3718.                exit
  3719.  
  3720.             endif
  3721.  
  3722.             nCurPos = Ftell( m->nHandle )
  3723.  
  3724.          enddo
  3725.  
  3726.          if nFoundPos < 1
  3727.  
  3728.             nJunk = fseek( m->nHandle, m->nStartPos, 0 )
  3729.  
  3730.          else
  3731.  
  3732.             nJunk = fseek( m->nHandle, m->nFoundPos, 0 )
  3733.  
  3734.          endif
  3735.  
  3736.       endif
  3737.  
  3738. RETURN( m->nFoundPos )
  3739. *-- EoF: FLocate()
  3740.  
  3741. FUNCTION FTell
  3742. *----------------------------------------------------------------------
  3743. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3744. *-- Date........: 04/26/1993
  3745. *-- Notes.......: A shorthand way of finding the current position of
  3746. *--               file pointer in a file, without moving the pointer.
  3747. *-- Written for.: dBASE IV, 1.5
  3748. *-- Rev. History: 04/26/1993  -- Original
  3749. *-- Calls.......: None
  3750. *-- Called by...: Any (specifically FLocate()).
  3751. *-- Usage.......: FTell(<nHandle>)
  3752. *-- Example.....: FTell(5)
  3753. *-- Returns.....: Current position of pointer in a file.
  3754. *-- Parameters..: nHandle  =  DOS file handle.
  3755. *----------------------------------------------------------------------
  3756.  
  3757.    parameters  nHandle
  3758.  
  3759. RETURN( fseek( m->nHandle, 0, 1 ) )
  3760. *-- EoF: FTell()
  3761.  
  3762. FUNCTION FLen
  3763. *----------------------------------------------------------------------
  3764. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3765. *-- Date........: 04/26/1993
  3766. *-- Notes.......: Finds length (in bytes) of a file and then returns
  3767. *--               the file pointer to byte 0.
  3768. *-- Written for.: dBASE IV, 1.5
  3769. *-- Rev. History: 04/26/1993  -- Original
  3770. *-- Calls.......: None
  3771. *-- Called by...: Any (specifically FLocate()).
  3772. *-- Usage.......: FLen(<nHandle>)
  3773. *-- Example.....: FLen(6)
  3774. *-- Returns.....: nLength   =  Length of file in bytes
  3775. *-- Parameters..: nHandle   =  DOS file handle
  3776. *----------------------------------------------------------------------
  3777.  
  3778.    parameters nHandle
  3779.    private nCurPos, nLength, xJunk
  3780.  
  3781.    *-- Locate current position in file without moving pointer
  3782.    nCurPos = Ftell( m->nHandle )
  3783.  
  3784.    *-- Find the length of the file by shifting the pointer to the end
  3785.    nLength = fseek( m->nHandle, 0, 2 )
  3786.  
  3787.    *-- Return the pointer to the original starting point
  3788.    nJunk   = fseek( m->nHandle, m->nCurPos, 0 )
  3789.  
  3790. RETURN( m->nLength )
  3791. *-- EoF: FLen()
  3792.  
  3793. FUNCTION FReadI32
  3794. *----------------------------------------------------------------------
  3795. *-- Programmer..: Borland
  3796. *-- Date........: 1992
  3797. *-- Notes.......: Convert a 4-byte integer to its decimal value.
  3798. *--               The UDF reads the next 4 bytes from a file and
  3799. *--               converts them to decimal.
  3800. *-- Written for.: dBASE IV, 1.5
  3801. *-- Rev. History: Original
  3802. *-- Calls.......: None
  3803. *-- Called by...: Any (specifically FindTagExp)
  3804. *-- Usage.......: FReadI32(<nHandle>)
  3805. *-- Example.....: FReadI32(4)
  3806. *-- Returns.....: nResult  =  Decimal value of next 4 bytes in file
  3807. *-- Parameters..: nHandle  =  DOS file handle
  3808. *----------------------------------------------------------------------
  3809.  
  3810.    parameters nHandle
  3811.    private nResult, nByte1, nByte2, nByte3, nByte4
  3812.  
  3813.    nResult = 0
  3814.    nByte1  = asc( fread( m->nHandle,1 ) )
  3815.    nByte2  = asc( fread( m->nHandle,1 ) ) * 256
  3816.    nByte3  = asc( fread( m->nHandle,1 ) ) * 256 * 256
  3817.    nByte4  = asc( fread( m->nHandle,1 ) ) * 256 * 256 * 256
  3818.    nResult = m->nByte1 + m->nByte2 + m->nByte3 + m->nByte4
  3819.  
  3820. RETURN (m->nResult)
  3821. *-- EoF: FReadI32()
  3822.  
  3823. FUNCTION MDXGaug2
  3824. *-----------------------------------------------------------------------
  3825. *-- Programmer..: Patrick Nelson (CIS: 71042,3445)
  3826. *-- Date........: 11/17/1993
  3827. *-- Notes.......: Indexes a database, showing a fuel-gauge style 
  3828. *--               progress indicator during the process.  You must SET 
  3829. *--               DBTRAP OFF in the calling routine or at the dot 
  3830. *--               prompt (or in your CONFIG.DB: DBTRAP=OFF).  
  3831. *--               Initially DelMDX() to del the MDX and reference to 
  3832. *--               it in the DBF.  This routine slows down indexing, 
  3833. *--               but the user sees the progress.
  3834. *-- Written for.: dBASE IV ver 1.5
  3835. *-- Rev. History: 04/26/1993 - Original: Rose Vines (CIS: 100026,3153)
  3836. *--               11/17/1993 - Modified for cross directory access of 
  3837. *--                            DBF/MDX - and passing of bar colors (PN)
  3838. *-- Calls.......: Gaug2(), DelGauge()
  3839. *-- Called by...: Any
  3840. *-- Usage.......: MDXGaug2("<cDataFile>","<cIndexExp>","<cMTag>",;
  3841. *--                        "<cMdxName>","<cClr>","<cClr>","<cClr>",;
  3842. *--                         <nURow>,<nLCol>)
  3843. *-- Example.....: x = MDXGaug2("FRED","LNAME+FNAME","FULLNAME","","",;
  3844. *--                            "","",0,0)
  3845. *--                 Indexes FRED.DBF residing in current directory on 
  3846. *--                 the last and first names, to the production MDX with
  3847. *--                 a tagname of FULLNAME.  Uses default colours and 
  3848. *--                 positions it at 0,0.
  3849. *--               x = MDXGaug2("\APP\DATA\FRED","substr(LNAME,5)",;
  3850. *--                            "SHORTNAME","OTHERS","w+/gr,,n/gr",;
  3851. *--                            "w+/b","g/g",10,15)
  3852. *--                 Indexes FRED.DBF residing in \APP\DATA on 1st 5 char
  3853. *--                 of lname to a non-production MDX called OTHERS, 
  3854. *--                 tagname SHORTNAME. Sets colours of the window and 
  3855. *--                 fuel-gauge empty & full and positions it starting at 
  3856. *--                 10,15.
  3857. *-- Returns.....: nError    =  0 if MDX header was updated correctly
  3858. *--                         =  1 if MDX header couldn't be updated
  3859. *-- Parameters..: cDataFile =  DBF to be indexed.  Can be in any 
  3860. *--                            directory.
  3861. *--               cMdxExpr  =  Indexing expression
  3862. *--               cMdxTag   =  Index TAG name
  3863. *--               cMdxName  =  MDX name - only needed if using a
  3864. *--                            non-production MDX.
  3865. *--               cClrBox   =  Colours for fuel gauge Window.  Use basic
  3866. *--                            window coloring syntax.
  3867. *--               cClrEmp   =  Colours for fuel gauge bar empty.
  3868. *--               cClrFul   =  Colours for fuel gauge bar full.
  3869. *--               nURow     =  Starting row for the fuel gauge on 
  3870. *--                            screen. Must be less than 20 - if not, 
  3871. *--                            the program will make nURow = 19.
  3872. *--               nLCol     =  Starting column for the fuel gauge.
  3873. *--                            Must be less than 26 - if not, the 
  3874. *--                            program will make nLCol = 25.
  3875. *-----------------------------------------------------------------------
  3876.    parameters cDbfName,cMdxExpr,cMdxTag,cMdxName,cClrBox,cClrEmp,;
  3877.               cClrFul,nURow,nLCol
  3878.    private nBarLen, cBarPad, cIndex, nError, nRecInt, nBarFull
  3879.    use (cDbfName) exclusive
  3880.    cMdxExpr = upper(cMdxExpr)
  3881.    cMdxTag  = upper(cMdxTag)
  3882.    cCurs    = set("CURSOR")
  3883.    set cursor off
  3884.    
  3885.    *-- If colour parameter is blank, use default colour scheme
  3886.    if m->cClrBox <> ""
  3887.       m->cClrBox = SET("ATTR")
  3888.    endif
  3889.    if isblank(m->cClrEmp)
  3890.       m->cClrEmp = "w+/b"
  3891.    endif 
  3892.    if isblank(m->cClrFul)
  3893.       m->cClrFul = "b/b"
  3894.    endif 
  3895.    if m->nURow > 19
  3896.       m->nURow = 19
  3897.    endif
  3898.    if m->nLCol > 25
  3899.       m->nLCol = 25
  3900.    endif
  3901.    
  3902.    *-- Determine width of fuel-gauge
  3903.    if reccount() > 40
  3904.       m->nRecInt   = int(reccount()/40)
  3905.       m->nBarLen   = int( reccount() / m->nRecInt )
  3906.    else
  3907.       m->nBarLen   = reccount() + 1
  3908.    endif
  3909.    m->cBarPad = space(round((m->nBarLen-16)/3,0))
  3910.    
  3911.    *-- Display fuel-gauge window and empty gauge
  3912.    define window wGauge from m->nURow, m->nLCol to ;
  3913.                    m->nURow+5,m->nBarLen+m->nLCol+3 ;
  3914.                    color &cClrBox.
  3915.    save screen to sGuage
  3916.    do Shadow with m->nURow,m->nLCol,m->nURow+5,m->nBarLen+m->nLCol+3
  3917.    activate window wGauge
  3918.    @ 0,0 say "Indexing "+dbf()+" For "+cMdxTag
  3919.    @ 1,1 say "0%  " + m->cBarPad + "25% " + m->cBarPad + "75% " +;
  3920.                    m->cBarPad + "100%"
  3921.    @ 2,1 say replicate( chr(219), m->nBarLen ) color &cClrEmp.
  3922.    @ 2,1 say ""
  3923.    
  3924.    *-- Check if it's a production index or not, and then
  3925.    *-- use the appropriate index expression. The FOR condition
  3926.    *-- in the expression "fills up" the fuel gauge.
  3927.    if "" = m->cMdxName
  3928.       index on &cMdxExpr. tag &cMdxTag. for Gaug2(m->cClrFul,m->cClrEmp)
  3929.    else
  3930.       index on &cMdxExpr. tag &cMdxTag. of &cMdxName. for ;
  3931.                                          Gaug2(m->cClrFul,m->cClrEmp)
  3932.    endif
  3933.    set color to &cClrBox.
  3934.    
  3935.    *-- Clean up
  3936.    @ 3,1 say "Closing files..." color w+/gr
  3937.    nError  =  0
  3938.    cFlPth  = set("FULLPATH")
  3939.    set fullpath on
  3940.    cIndex  = mdx()
  3941.    set fullpath &cFlPth.
  3942.    use
  3943.    
  3944.    *-- Call UDF to delete reference to Gaug2() UDF from MDX header
  3945.    nError = DelGauge(m->cIndex, m->cMdxTag)
  3946.    deactivate window wGauge
  3947.    release    window wGauge
  3948.    restore screen from sGuage
  3949.    release screen      sGuage
  3950.    set cursor &cCurs.
  3951.  
  3952. RETURN (nError)
  3953. *-- EoF: MDXGaug2()
  3954.  
  3955. FUNCTION Gaug2
  3956. *-----------------------------------------------------------------------
  3957. *-- Programmer..: Patrick Nelson (CIS: 71042,3445)
  3958. *-- Date........: 11/17/93
  3959. *-- Notes.......: Routine used by MDXGaug2() to "fill up" the fuel-gauge
  3960. *--               on screen during indexing.
  3961. *--               It is called from an indexing "FOR" expression, and 
  3962. *--               always returns .T. to include all records in the 
  3963. *--               index.
  3964. *-- Written for.: dBASE IV, 1.5
  3965. *-- Rev. History: 04/26/1993 - Original: Rose Vines (CIS: 100026,3153)
  3966. *--               11/17/1993 - Modified for cross directory access of 
  3967. *--                            DBF/MDX - and passing of bar colors (PN)
  3968. *-- Calls.......: None
  3969. *-- Called by...: MDXGaug2()           Function in FILES.PRG
  3970. *-- Usage.......: Gaug2(<cClrFul>,<cClrEmp>)
  3971. *-- Example.....: Gaug2(m->cClrFul,m->cClrEmp)
  3972. *-- Returns.....: .T.
  3973. *-- Parameters..: cClrFul = Color of 'full'
  3974. *--               cClrEmp = Color of 'empty'
  3975. *-----------------------------------------------------------------------
  3976.    
  3977.    parameters cClrFul,cClrEmp
  3978.    
  3979.    *-- Every time 2% of the file or so is indexed...
  3980.    if reccount() > 40
  3981.       if mod( recno(), m->nRecInt ) = 0
  3982.          *-- Display a solid bar character to "fill up" the gauge
  3983.          set color to &cClrFul.
  3984.          ?? chr(219)  &&177
  3985.          set color to &cClrEmp.
  3986.       endif
  3987.    else
  3988.       set color to &cClrFul.
  3989.       ?? chr(219)  &&177
  3990.       set color to &cClrEmp.
  3991.    endif
  3992.    
  3993. RETURN (.T.)
  3994. *-- EoF: Gaug2()
  3995.  
  3996. FUNCTION NewRec
  3997. *----------------------------------------------------------------------
  3998. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  3999. *-- Date........: 05/03/1993 
  4000. *-- Notes.......: This will recycle records instead of APPENDING Blank. 
  4001. *--               Effectively it recycles "deleted" records, but it
  4002. *--               requires that your routines that delete records
  4003. *--               actually blank them, and do NOT pack the database.
  4004. *--               If no blank records are in the database, the routine
  4005. *--               will append blank. Your delete routines should:
  4006. *--                 BLANK the record and
  4007. *--                 DELETE the record as well (turn on the delete flag)
  4008. *--               NOTE: This routine assumes you are using a character
  4009. *--                     field for your .MDX Tag Expression.
  4010. *-- Written for.: dBASE IV, 1.5 (will work with 1.1, but requires
  4011. *--                              that you create a BLANK() routine ...)
  4012. *-- Rev. History: 05/28/1992 -- Original
  4013. *--               05/03/1993 -- &cTagExpr. correction noted by Zak.
  4014. *-- Calls.......: RecLock()            Function in FILES.PRG
  4015. *-- Called by...: Any
  4016. *-- Usage.......: NewRec()
  4017. *-- Example.....: IF NewRec()
  4018. *--                  replace fields with new data
  4019. *--               ELSE
  4020. *--                  error routine
  4021. *--               ENDIF
  4022. *-- Returns.....: Logical -- .T. if new record is locked, .F. if not.
  4023. *-- Parameters..: None
  4024. *----------------------------------------------------------------------
  4025.  
  4026.    private lOldExact, cTagExpr
  4027.  
  4028.    lOldExact = set("EXACT")="ON"
  4029.    set exact on
  4030.    set deleted off
  4031.  
  4032.    *-- get tag expression for current .MDX tag
  4033.    cTagExpr = key(tagno(order()))
  4034.  
  4035.    *-- look for a blank record, and attempt to lock the record
  4036.    if seek(space(len(&cTagExpr.))) .and. rlock()
  4037.       recall                       && turn off deleted flag
  4038.    else                            && no blank records
  4039.       append blank                 && add one
  4040.    endif
  4041.  
  4042.    *-- reset
  4043.    set deleted on
  4044.    if .not. lOldExact
  4045.       set exact off
  4046.    endif
  4047.  
  4048. RETURN RecLock()   && if using 1.1, replace with RLock() internal dBASE
  4049.                    *  function
  4050. *-- EoF: NewRec()
  4051.  
  4052. FUNCTION IsNetDir
  4053. *-----------------------------------------------------------------------
  4054. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  4055. *-- Date........: 07/14/1993
  4056. *-- Notes.......: Tests for existence of a directory
  4057. *--               NOTE: on Novell Netware 3.11, FILE("Z:\DBASE\NUL")
  4058. *--               always returns .T. even if disk volume Z: is not 
  4059. *--               MAPped by the user, or if \DBASE does NOT exist. This
  4060. *--               is a quirk of the interaction between Netware and DOS
  4061. *-- Written for.: dBASE IV v1.5+
  4062. *-- Rev. History: 07/14/1993  first draft
  4063. *--               based on pseudocode by Pat Kennedy, Borland Tech 
  4064. *--               Support
  4065. *-- Calls.......: Net_Err        Procedure in FILES.PRG
  4066. *-- Called by...: Any
  4067. *-- Usage.......: IsNetDir(<cTestDir>)
  4068. *-- Example.....: if IsNetDir("F:\DBASE\DATA")
  4069. *-- Returns.....: logical .T. if directory is available, .F. if not
  4070. *-- Parameters..: cTestDir = [disk:] and directory to check for
  4071. *-- Side Effect.: Changes ON ERROR setting to nul.
  4072. *-----------------------------------------------------------------------
  4073.  
  4074.    parameter cTestDir
  4075.  
  4076.    *-- if parameter is empty, return
  4077.    if isblank(m->cTestDir)
  4078.       return .F.
  4079.    endif
  4080.  
  4081.    *-- if lNetError does not exist, create it
  4082.    if type("lNetError")="U"
  4083.       public lNetError
  4084.    endif
  4085.    m->lNetError = .F.
  4086.  
  4087.    *-- if there's an error, call routine below
  4088.    on error do Net_Err
  4089.  
  4090.    *-- save current directory settings
  4091.    private cOldDir
  4092.    cOldDir = set("directory")
  4093.  
  4094.    *-- change to new directory -- if error, this is where it will
  4095.    *-- occur, and routine will be called ...
  4096.    set directory to &cTestDir.
  4097.     
  4098.    *-- cleanup and return to original directory setting
  4099.    on error
  4100.    set directory to &cOldDir.
  4101.  
  4102. RETURN .not. m->lNetError
  4103. *-- EoF: IsNetDir()
  4104.  
  4105. PROCEDURE Net_Err
  4106. *-----------------------------------------------------------------------
  4107. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  4108. *-- Date........: 07/14/1993
  4109. *-- Notes.......: Routine to handle error processing if a network 
  4110. *--               directory doesn't exist. This is part of IsNetDir().
  4111. *-- Written for.: dBASE IV, 1.5 ...
  4112. *-- Rev. History: 07/14/1993 -- Original Release
  4113. *-- Calls.......: None
  4114. *-- Called by...: IsNetDir()        Function in FILES.PRG
  4115. *-- Usage.......: On error do Net_Err
  4116. *-- Example.....: ditto.
  4117. *-- Returns.....: None
  4118. *-- Parameters..: None
  4119. *-----------------------------------------------------------------------
  4120.  
  4121.    do case
  4122.       case ERROR() = 413
  4123.          * 413 - Not a valid directory:
  4124.          lNetError = .T.
  4125.       case ERROR() = 412
  4126.          * 412 - Not a valid Disk drive:
  4127.          lNetError = .T.
  4128.       otherwise
  4129.          wait "Unknown error: "+str(errno())+" "+errmsg()
  4130.    endcase
  4131.  
  4132. RETURN
  4133. *-- EoP: Net_Err
  4134.  
  4135. *-----------------------------------------------------------------------
  4136. *-- Routines here by courtesy
  4137. *-----------------------------------------------------------------------
  4138.  
  4139. PROCEDURE Shadow
  4140. *-----------------------------------------------------------------------
  4141. *-- Programmer..: Ashton-Tate
  4142. *-- Date........: 06/02/1993
  4143. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  4144. *--               picklist functions)
  4145. *-- Written for.: dBASE IV, 1.1
  4146. *-- Rev. History: 05/23/1991 - original procedure.
  4147. *--               12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to 
  4148. *--                 check for columns exceeding 79, and temporarily 
  4149. *--                 change last col. value (so routine doesn't "blow 
  4150. *--                 up").
  4151. *--               01/27/1992 -- Modifiedy by Ken Mayer to check for 
  4152. *--                 bottom of screen, based on what Jim did above. No 
  4153. *--                 further than 23.
  4154. *--               06/02/1993 -- Modified to handle screens larger than 
  4155. *--                 24 lines. (KJM)
  4156. *-- Calls.......: None
  4157. *-- Called by...: Too many to list ...
  4158. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  4159. *-- Example.....: save screen to sMain
  4160. *--               activate screen
  4161. *--               define window wError from 5,15 to 15,65 double color;
  4162. *--                    rg+/r,rg+/r,rg+/r
  4163. *--               do shadow with 5,15,15,65
  4164. *--               activate window WError
  4165. *--                && perform actions in window
  4166. *--               release window WError
  4167. *--               restore screen from sMain
  4168. *--               release screen sMain
  4169. *-- Returns.....: None
  4170. *-- Parameters..: nULRow = Upper Left Row position
  4171. *--               nULCol = Upper Left Column position (x,y)
  4172. *--               nBRRow = Bottom Right Row position
  4173. *--               nBRCol = Bottom Right Column position (x2,y2)
  4174. *-----------------------------------------------------------------------
  4175.  
  4176.    parameters nULRow,nULCol,nBRRow,nBRCOL
  4177.    private nTempRow,nTempCol,nIncRow,nIncCol,cScreen,nScreen
  4178.  
  4179.    *-- if screen is larger than 24 lines (EGA43, EGA50 ...)
  4180.    m->cScreen = set("DISPLAY")
  4181.    if m->cScreen = "MONO"
  4182.       m->nScreen = 23
  4183.    else
  4184.       m->nScreen = val(right(m->cScreen,2))-2
  4185.    endif
  4186.       
  4187.    m->nTempRow = iif(m->nBRRow+1>m->nScreen,m->nScreen,m->nBRRow+1)
  4188.    m->nTempCol = iif(m->nBRCol+2>79,79,m->nBRCol+2)
  4189.    m->nIncRow = 1
  4190.    m->nIncCol = (m->nBRCol-m->nULCol) / (m->nBRRow-m->nULRow)
  4191.    do while m->nTempRow <> m->nULRow .or. m->nTempCol <> m->nULCol+2
  4192.       m->nRightCol = m->nBRCol
  4193.       m->nBRCol = iif(m->nBRCol + 2 > 79,77,m->nBRCol)
  4194.       m->nBotRow = m->nBRRow
  4195.       m->nBRRow = iif(m->nBRRow + 1 > m->nScreen,m->nScreen-1,m->nBRRow)
  4196.       @ m->nTempRow,m->nTempCol fill to m->nBRRow+1,m->nBRCol+2 ;
  4197.           color n+/n
  4198.       m->nBRCol = m->nRightCol
  4199.       m->nBRRow = m->nBotRow
  4200.       m->nTempRow = iif(m->nTempRow<>m->nULRow,m->nTempRow -m->nIncRow,;
  4201.                         m->nTempRow)
  4202.       m->nTempCol = iif(m->nTempCol<>m->nULCol+2,m->nTempCol - ;
  4203.                         m->nIncCol,m->nTempCol)
  4204.       m->nTempCol = iif(m->nTempCol<m->nULCol+2,m->nULCol+2,m->nTempCol)
  4205.    enddo
  4206.    
  4207. RETURN
  4208. *-- EoP: Shadow
  4209.  
  4210. *-----------------------------------------------------------------------
  4211. *-- EoP: FILES.PRG
  4212. *-----------------------------------------------------------------------
  4213.  
  4214.